core/generic/single/single.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.algebra
   4 combinators definitions generic hashtables kernel
   5 kernel.private layouts math namespaces quotations
   6 sequences words generic.single.private effects make
   7 combinators.private ;
   8 FROM: assocs => change-at ;
   9 IN: generic.single
  10
  11 ERROR: no-method object generic ;
  12
  13 ERROR: inconsistent-next-method class generic ;
  14
  15 TUPLE: single-combination ;
  16
  17 PREDICATE: single-generic < generic
  18     "combination" word-prop single-combination? ;
  19
  20 M: single-generic make-inline cannot-be-inline ;
  21
  22 GENERIC: dispatch# ( word -- n )
  23
  24 M: generic dispatch# "combination" word-prop dispatch# ;
  25
  26 SYMBOL: assumed
  27 SYMBOL: default
  28 SYMBOL: generic-word
  29 SYMBOL: combination
  30
  31 : with-combination ( combination quot -- )
  32     [ combination ] dip with-variable ; inline
  33
  34 HOOK: picker combination ( -- quot )
  35
  36 M: single-combination next-method-quot* ( class generic combination -- quot )
  37     [
  38         2dup next-method dup [
  39             [
  40                 pick "predicate" word-prop %
  41                 1quotation ,
  42                 [ inconsistent-next-method ] 2curry ,
  43                 \ if ,
  44             ] [ ] make picker prepend
  45         ] [ 3drop f ] if
  46     ] with-combination ;
  47
  48 : method-for-object ( obj word -- method )
  49     [ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
  50     [ "default-method" word-prop ]
  51     bi or ;
  52
  53 M: single-combination make-default-method
  54     [ [ picker ] dip [ no-method ] curry append ] with-combination ;
  55
  56 ! ! ! Build an engine ! ! !
  57
  58 : find-default ( methods -- default )
  59     #! Side-effects methods.
  60     [ object bootstrap-word ] dip delete-at* [
  61         drop generic-word get "default-method" word-prop
  62     ] unless ;
  63
  64 ! 1. Flatten methods
  65 TUPLE: predicate-engine class methods ;
  66
  67 C: <predicate-engine> predicate-engine
  68
  69 : push-method ( method class atomic assoc -- )
  70     dupd [
  71         [ ] [ H{ } clone <predicate-engine> ] ?if
  72         [ methods>> set-at ] keep
  73     ] change-at ;
  74
  75 : flatten-method ( method class assoc -- )
  76     over flatten-class keys
  77     [ swap push-method ] with with with each ;
  78
  79 : flatten-methods ( assoc -- assoc' )
  80     H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
  81
  82 ! 2. Convert methods
  83 : split-methods ( assoc class -- first second )
  84     [ [ nip class<= not ] curry assoc-filter ]
  85     [ [ nip class<=     ] curry assoc-filter ] 2bi ;
  86
  87 : convert-methods ( assoc class word -- assoc' )
  88     over [ split-methods ] 2dip pick assoc-empty?
  89     [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
  90
  91 ! 2.1 Convert tuple methods
  92 TUPLE: echelon-dispatch-engine n methods ;
  93
  94 C: <echelon-dispatch-engine> echelon-dispatch-engine
  95
  96 TUPLE: tuple-dispatch-engine echelons ;
  97
  98 : push-echelon ( class method assoc -- )
  99     [ swap dup "layout" word-prop third ] dip
 100     [ ?set-at ] change-at ;
 101
 102 : echelon-sort ( assoc -- assoc' )
 103     #! Convert an assoc mapping classes to methods into an
 104     #! assoc mapping echelons to assocs. The first echelon
 105     #! is always there
 106     H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
 107
 108 : copy-superclass-methods ( engine superclass assoc -- )
 109     at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ;
 110
 111 : copy-superclasses-methods ( class engine assoc -- )
 112     [ superclasses ] 2dip
 113     [ swapd copy-superclass-methods ] 2curry each ;
 114
 115 : convert-tuple-inheritance ( assoc -- assoc' )
 116     #! A method on a superclass A might have a higher precedence
 117     #! than a method on a subclass B, if the methods are
 118     #! defined on incomparable classes that happen to contain
 119     #! A and B, respectively. Copy A's methods into B's set so
 120     #! that they can be sorted and selected properly.
 121     dup dup [ copy-superclasses-methods ] curry assoc-each ;
 122
 123 : <tuple-dispatch-engine> ( methods -- engine )
 124     convert-tuple-inheritance echelon-sort
 125     [ dupd <echelon-dispatch-engine> ] assoc-map
 126     \ tuple-dispatch-engine boa ;
 127
 128 : convert-tuple-methods ( assoc -- assoc' )
 129     tuple bootstrap-word
 130     \ <tuple-dispatch-engine> convert-methods ;
 131
 132 ! 3 Tag methods
 133 TUPLE: tag-dispatch-engine methods ;
 134
 135 C: <tag-dispatch-engine> tag-dispatch-engine
 136
 137 : <engine> ( assoc -- engine )
 138     flatten-methods
 139     convert-tuple-methods
 140     <tag-dispatch-engine> ;
 141
 142 ! ! ! Compile engine ! ! !
 143 GENERIC: compile-engine ( engine -- obj )
 144
 145 : compile-engines ( assoc -- assoc' )
 146     [ compile-engine ] assoc-map ;
 147
 148 : compile-engines* ( assoc -- assoc' )
 149     [ over assumed [ compile-engine ] with-variable ] assoc-map ;
 150
 151 : direct-dispatch-table ( assoc n -- table )
 152     default get <array> <enum> swap assoc-union! seq>> ;
 153
 154 : tag-number ( class -- n ) "type" word-prop ;
 155
 156 M: tag-dispatch-engine compile-engine
 157     methods>> compile-engines*
 158     [ [ tag-number ] dip ] assoc-map
 159     num-types get direct-dispatch-table ;
 160
 161 : build-fast-hash ( methods -- buckets )
 162     >alist V{ } clone [ hashcode 1array ] distribute-buckets
 163     [ compile-engines* >alist { } join ] map ;
 164
 165 M: echelon-dispatch-engine compile-engine
 166     dup n>> 0 = [
 167         methods>> dup assoc-size {
 168             { 0 [ drop default get ] }
 169             { 1 [ >alist first second compile-engine ] }
 170         } case
 171     ] [
 172         methods>> compile-engines* build-fast-hash
 173     ] if ;
 174
 175 M: tuple-dispatch-engine compile-engine
 176     tuple assumed [
 177         echelons>> compile-engines
 178         dup keys supremum 1 + f <array>
 179         <enum> swap assoc-union! seq>>
 180     ] with-variable ;
 181
 182 PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
 183
 184 SYMBOL: predicate-engines
 185
 186 : sort-methods ( assoc -- assoc' )
 187     >alist [ keys sort-classes ] keep extract-keys ;
 188
 189 : quote-methods ( assoc -- assoc' )
 190     [ 1quotation \ drop prefix ] assoc-map ;
 191
 192 : find-predicate-engine ( classes -- word )
 193     predicate-engines get [ at ] curry map-find drop ;
 194
 195 : next-predicate-engine ( engine -- word )
 196     class>> superclasses
 197     find-predicate-engine
 198     default get or ;
 199
 200 : methods-with-default ( engine -- assoc )
 201     [ methods>> clone ] [ next-predicate-engine ] bi
 202     object bootstrap-word pick set-at ;
 203
 204 : keep-going? ( assoc -- ? )
 205     assumed get swap second first class<= ;
 206
 207 ERROR: unreachable ;
 208
 209 : prune-redundant-predicates ( assoc -- default assoc' )
 210     {
 211         { [ dup empty? ] [ drop [ unreachable ] { } ] }
 212         { [ dup length 1 = ] [ first second { } ] }
 213         { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
 214         [ [ first second ] [ rest-slice ] bi ]
 215     } cond ;
 216
 217 : class-predicates ( assoc -- assoc )
 218     [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
 219
 220 : <predicate-engine-word> ( -- word )
 221     generic-word get name>> "/predicate-engine" append f <word>
 222     dup generic-word get "owner-generic" set-word-prop ;
 223
 224 M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
 225
 226 : define-predicate-engine ( alist -- word )
 227     [ <predicate-engine-word> ] dip
 228     [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
 229
 230 : compile-predicate-engine ( engine -- word )
 231     methods-with-default
 232     sort-methods
 233     quote-methods
 234     prune-redundant-predicates
 235     class-predicates
 236     [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
 237
 238 M: predicate-engine compile-engine
 239     [ compile-predicate-engine ] [ class>> ] bi
 240     [ drop ] [ predicate-engines get set-at ] 2bi ;
 241
 242 M: word compile-engine ;
 243
 244 M: f compile-engine ;
 245
 246 : build-decision-tree ( generic -- methods )
 247     [ "engines" word-prop forget-all ]
 248     [ V{ } clone "engines" set-word-prop ]
 249     [
 250         "methods" word-prop clone
 251         [ find-default default set ]
 252         [ <engine> compile-engine ] bi
 253     ] tri ;
 254
 255 HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
 256
 257 M: single-combination inline-cache-quots 2drop f f ;
 258
 259 : define-inline-cache-quot ( word methods -- )
 260     [ drop ] [ inline-cache-quots ] 2bi
 261     [ >>pic-def ] [ >>pic-tail-def ] bi*
 262     drop ;
 263
 264 HOOK: mega-cache-quot combination ( methods -- quot/f )
 265
 266 M: single-combination perform-combination
 267     [
 268         H{ } clone predicate-engines set
 269         dup generic-word set
 270         dup build-decision-tree
 271         [ "decision-tree" set-word-prop ]
 272         [ mega-cache-quot define ]
 273         [ define-inline-cache-quot ]
 274         2tri
 275     ] with-combination ;