/core/generic/single/single.factor

http://github.com/abeaumont/factor · Factor · 276 lines · 200 code · 68 blank · 8 comment · 18 complexity · 20669902f369b89161923dc918e06568 MD5 · raw file

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