/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
- ! Copyright (C) 2009, 2010 Slava Pestov.
- ! See http://factorcode.org/license.txt for BSD license.
- USING: accessors arrays assocs classes classes.algebra
- combinators combinators.private definitions effects generic
- hashtables kernel layouts make math namespaces quotations
- sequences words ;
- FROM: assocs => change-at ;
- IN: generic.single
- ERROR: no-method object generic ;
- ERROR: inconsistent-next-method class generic ;
- TUPLE: single-combination ;
- PREDICATE: single-generic < generic
- "combination" word-prop single-combination? ;
- M: single-generic make-inline cannot-be-inline ;
- GENERIC: dispatch# ( word -- n )
- M: generic dispatch# "combination" word-prop dispatch# ;
- SYMBOL: assumed
- SYMBOL: default
- SYMBOL: generic-word
- SYMBOL: combination
- : with-combination ( combination quot -- )
- [ combination ] dip with-variable ; inline
- HOOK: picker combination ( -- quot )
- M: single-combination next-method-quot* ( class generic combination -- quot )
- [
- 2dup next-method dup [
- [
- pick predicate-def %
- 1quotation ,
- [ inconsistent-next-method ] 2curry ,
- \ if ,
- ] [ ] make picker prepend
- ] [ 3drop f ] if
- ] with-combination ;
- : method-for-object ( obj word -- method )
- [
- [ method-classes [ instance? ] with filter smallest-class ] keep
- ?lookup-method
- ] [ "default-method" word-prop ]
- bi or ;
- M: single-combination make-default-method
- [ [ picker ] dip [ no-method ] curry append ] with-combination ;
- ! ! ! Build an engine ! ! !
- : find-default ( methods -- default )
- #! Side-effects methods.
- [ object bootstrap-word ] dip delete-at* [
- drop generic-word get "default-method" word-prop
- ] unless ;
- ! 1. Flatten methods
- TUPLE: predicate-engine class methods ;
- C: <predicate-engine> predicate-engine
- : push-method ( method class atomic assoc -- )
- dupd [
- [ ] [ H{ } clone <predicate-engine> ] ?if
- [ methods>> set-at ] keep
- ] change-at ;
- : flatten-method ( method class assoc -- )
- over flatten-class keys
- [ swap push-method ] with with with each ;
- : flatten-methods ( assoc -- assoc' )
- H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
- ! 2. Convert methods
- : split-methods ( assoc class -- first second )
- [ [ nip class<= not ] curry assoc-filter ]
- [ [ nip class<= ] curry assoc-filter ] 2bi ;
- : convert-methods ( assoc class word -- assoc' )
- over [ split-methods ] 2dip pick assoc-empty?
- [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
- ! 2.1 Convert tuple methods
- TUPLE: echelon-dispatch-engine n methods ;
- C: <echelon-dispatch-engine> echelon-dispatch-engine
- TUPLE: tuple-dispatch-engine echelons ;
- : push-echelon ( class method assoc -- )
- [ swap dup "layout" word-prop third ] dip
- [ ?set-at ] change-at ;
- : echelon-sort ( assoc -- assoc' )
- #! Convert an assoc mapping classes to methods into an
- #! assoc mapping echelons to assocs. The first echelon
- #! is always there
- H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
- : copy-superclass-methods ( engine superclass assoc -- )
- at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ;
- : copy-superclasses-methods ( class engine assoc -- )
- [ superclasses ] 2dip
- [ swapd copy-superclass-methods ] 2curry each ;
- : convert-tuple-inheritance ( assoc -- assoc' )
- #! A method on a superclass A might have a higher precedence
- #! than a method on a subclass B, if the methods are
- #! defined on incomparable classes that happen to contain
- #! A and B, respectively. Copy A's methods into B's set so
- #! that they can be sorted and selected properly.
- dup dup [ copy-superclasses-methods ] curry assoc-each ;
- : <tuple-dispatch-engine> ( methods -- engine )
- convert-tuple-inheritance echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
- : convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> convert-methods ;
- ! 3 Tag methods
- TUPLE: tag-dispatch-engine methods ;
- C: <tag-dispatch-engine> tag-dispatch-engine
- : <engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- <tag-dispatch-engine> ;
- ! ! ! Compile engine ! ! !
- GENERIC: compile-engine ( engine -- obj )
- : compile-engines ( assoc -- assoc' )
- [ compile-engine ] assoc-map ;
- : compile-engines* ( assoc -- assoc' )
- [ over assumed [ compile-engine ] with-variable ] assoc-map ;
- : direct-dispatch-table ( assoc n -- table )
- default get <array> <enum> swap assoc-union! seq>> ;
- : tag-number ( class -- n ) "type" word-prop ;
- M: tag-dispatch-engine compile-engine
- methods>> compile-engines*
- [ [ tag-number ] dip ] assoc-map
- num-types get direct-dispatch-table ;
- : build-fast-hash ( methods -- buckets )
- >alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ compile-engines* >alist { } join ] map ;
- M: echelon-dispatch-engine compile-engine
- dup n>> 0 = [
- methods>> dup assoc-size {
- { 0 [ drop default get ] }
- { 1 [ >alist first second compile-engine ] }
- } case
- ] [
- methods>> compile-engines* build-fast-hash
- ] if ;
- M: tuple-dispatch-engine compile-engine
- tuple assumed [
- echelons>> compile-engines
- dup keys supremum 1 + f <array>
- <enum> swap assoc-union! seq>>
- ] with-variable ;
- PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
- SYMBOL: predicate-engines
- : sort-methods ( assoc -- assoc' )
- >alist [ keys sort-classes ] keep extract-keys ;
- : quote-methods ( assoc -- assoc' )
- [ 1quotation \ drop prefix ] assoc-map ;
- : find-predicate-engine ( classes -- word )
- predicate-engines get [ at ] curry map-find drop ;
- : next-predicate-engine ( engine -- word )
- class>> superclasses
- find-predicate-engine
- default get or ;
- : methods-with-default ( engine -- assoc )
- [ methods>> clone ] [ next-predicate-engine ] bi
- object bootstrap-word pick set-at ;
- : keep-going? ( assoc -- ? )
- assumed get swap second first class<= ;
- ERROR: unreachable ;
- : prune-redundant-predicates ( assoc -- default assoc' )
- {
- { [ dup empty? ] [ drop [ unreachable ] { } ] }
- { [ dup length 1 = ] [ first second { } ] }
- { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
- [ [ first second ] [ rest-slice ] bi ]
- } cond ;
- : class-predicates ( assoc -- assoc )
- [ [ predicate-def [ dup ] prepend ] dip ] assoc-map ;
- : <predicate-engine-word> ( -- word )
- generic-word get name>> "/predicate-engine" append f <word>
- dup generic-word get "owner-generic" set-word-prop ;
- M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
- : define-predicate-engine ( alist -- word )
- [ <predicate-engine-word> ] dip
- [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
- : compile-predicate-engine ( engine -- word )
- methods-with-default
- sort-methods
- quote-methods
- prune-redundant-predicates
- class-predicates
- [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
- M: predicate-engine compile-engine
- [ compile-predicate-engine ] [ class>> ] bi
- [ drop ] [ predicate-engines get set-at ] 2bi ;
- M: word compile-engine ;
- M: f compile-engine ;
- : build-decision-tree ( generic -- methods )
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop clone
- [ find-default default set ]
- [ <engine> compile-engine ] bi
- ] tri ;
- HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
- M: single-combination inline-cache-quots 2drop f f ;
- : define-inline-cache-quot ( word methods -- )
- [ drop ] [ inline-cache-quots ] 2bi
- [ >>pic-def ] [ >>pic-tail-def ] bi*
- drop ;
- HOOK: mega-cache-quot combination ( methods -- quot/f )
- M: single-combination perform-combination
- [
- H{ } clone predicate-engines set
- dup generic-word set
- dup build-decision-tree
- [ "decision-tree" set-word-prop ]
- [ mega-cache-quot define ]
- [ define-inline-cache-quot ]
- 2tri
- ] with-combination ;