core/generic/single/single.factor

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