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