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