From f2e11b955a4842102ccc31ea72feccdc7e009f96 Mon Sep 17 00:00:00 2001 From: timor Date: Sun, 14 Feb 2021 17:26:19 +0100 Subject: [PATCH] generic.multi: remove remnants from earlier attempts --- core/generic/multi/multi.factor | 217 +------------------------------- 1 file changed, 5 insertions(+), 212 deletions(-) diff --git a/core/generic/multi/multi.factor b/core/generic/multi/multi.factor index 6dd277f4008..8736db727f1 100644 --- a/core/generic/multi/multi.factor +++ b/core/generic/multi/multi.factor @@ -1,9 +1,8 @@ USING: accessors arrays assocs classes classes.algebra classes.algebra.private -classes.private combinators combinators.short-circuit -combinators.short-circuit.smart combinators.smart definitions effects -effects.parser generic generic.parser generic.single generic.single.private -generic.standard kernel layouts make math math.order namespaces parser -quotations see sequences sequences.zipped sets sorting vectors words ; +classes.private combinators combinators.short-circuit.smart combinators.smart +definitions effects effects.parser generic generic.parser generic.single +generic.single.private generic.standard kernel make math math.order namespaces +parser quotations sequences sets sorting vectors words ; IN: generic.multi @@ -30,54 +29,11 @@ GENERIC: dispatch-arity ( method -- n ) M: class dispatch-arity drop 1 ; M: covariant-tuple dispatch-arity classes>> length ; -: tuple-echelon ( class -- n ) "layout" word-prop third ; - -! DOING: wrapping class/method pairs into a wrapper because we need to modify -! the class : nth-type ( n method -- seq ) method-types nth ; -: echelon-method? ( class index method -- ? ) nth-type [ tuple-echelon ] same? ; - : method-applicable? ( class index method -- ? ) nth-type class<= ; -: tuple-dispatch? ( method -- ? ) method-types [ tuple class<= ] all? ; - -: echelon-methods ( class index methods -- seq ) - [ { [ echelon-method? ] [ method-applicable? ] } && ] 2with filter ; - -: direct-methods ( class index methods -- seq ) [ nth-type class= ] 2with filter ; - -! Covariant dispatch tuple -: method<= ( method1 method2 -- ? ) - [ method-types ] bi@ - { [ [ class<= ] 2all? ] - [ [ first2 class< ] any? ] } 2&& ; - -! Strict checking -: method-index< ( method1 method2 n -- ? ) - '[ _ swap nth-type ] bi@ class< ; - -! ! Associate dispatch classes to methods -! : methods-classes ( methods -- assoc ) -! [ dup method-types ] map>alist ; - -: assign-dispatch-class ( classes -- echelon classes' ) - unclip tuple-echelon swap ; - -: dispatch-methods ( index methods -- assoc ) - [ [ method-types nth ] keep ] with map>alist ; - ! flatten-methods ; - -: make-dispatch-tree? ( methods index -- res ) - { - [ drop length 1 > ] - [ [ first method-types length ] dip > ] - } && ; - ! { [ drop empty? not ] [ [ methlengh ] ] } - ! over empty? - ! [ 2drop f ] - ! [ swap first method-types length < ] if ; - +! TODO: this should probably be replaced with functionality from classes.algebra :: dispatch<=> ( class1 class2 -- <=> ) class1 class2 [ normalize-class ] bi@ :> ( c1 c2 ) c1 c2 compare-classes dup +incomparable+ = @@ -92,169 +48,6 @@ M: covariant-tuple dispatch-arity classes>> length ; : applicable-methods ( class index methods -- seq ) [ [ method-applicable? ] 2with filter ] keepd sort-methods-index ; -:: make-dispatch-tree ( methods index -- res ) - methods index sort-methods-index :> methods - methods [ method-types index swap nth ] map members - ! [ flatten-class ] gather - sort-classes - [| class | - ! class tuple-echelon :> echelon - class index methods [ direct-methods ] [ applicable-methods ] 3bi over diff - :> ( this-echelon rest-methods ) - this-echelon rest-methods union index 1 + make-dispatch-tree? - [ class this-echelon rest-methods union index 1 + make-dispatch-tree 2array ] - ! Combine into a single list for now - ! [ class this-echelon rest-methods 3array ] if - [ class this-echelon rest-methods union 2array ] if - ] map ; - -: rebalance-inheritance ( class assoc -- assoc ) - clone >vector - over [ nip class<= ] curry assoc-partition - swapd [ set-at ] keep - ! [ keys sort-classes ] [ >alist ] bi extract-keys - ; - -: generic-dispatch-tree ( generic -- tree ) - methods 0 make-dispatch-tree ; - -! * Building the engines - -TUPLE: tuple-dispatcher assoc n ; -C: tuple-dispatcher -TUPLE: tag-dispatcher < tuple-dispatcher ; -C: tag-dispatcher -TUPLE: external-dispatcher < tuple-dispatcher ; -C: external-dispatcher - -: new-dispatcher ( assoc n class -- obj ) - new swap >>n swap >>assoc ; - -! cache engines on dispatch index and remaining possibilities -SYMBOL: handled-dispatch - -: flat-dispatch? ( subtree -- ? ) - [ sequence? not ] all? ; - -ERROR: no-dispatch-error tree ; - -! each index gets their own cache -: new-cache ( cache class tree n -- cache class tree n ) - [ V{ } clone suffix ] 3dip ; - -: diff-cached ( cache class tree n -- cache class tree n ) - ! over hashtable? - ! [ - [ pick last diff ] dip - ! ] unless - ; - -: push-cache ( cache class obj tree -- cache class obj ) - dup flat-dispatch? [ reach last push-all ] [ drop ] if ; - -DEFER: build-dispatch-assoc -: build-dispatch ( cache tree n type -- dispatcher ) - [ [ build-dispatch-assoc ] keep ] dip new-dispatcher ; - -: build-tag-dispatcher ( cache tree n -- dispatcher ) - [ tuple swap rebalance-inheritance ] dip - tag-dispatcher build-dispatch ; - -: build-tuple-dispatcher ( cache tree n -- dispatcher ) - tuple-dispatcher build-dispatch ; - -! This is right now using factor's class sorting for breaking ambiguity. This -! means this place can not be used to check for ambiguities with the current -! linearization/inheritance model -: resolve-ambiguity ( tree n -- dispatcher ) - sort-methods-index first ; - ! [ ] - - ! Check for strict linear specificness - ! [ dup 2 ] dip '[ first2 _ method-index< ] all? - ! [ first ] - ! [ no-dispatch-error ] if ; - -: tuple-subtree? ( class subtree n -- class subtree n ? ) - pick tuple = - [ over flat-dispatch? not ] - [ f ] if ; - -! TODO: handle predicates -: build-dispatch-assoc ( cache tree n -- assoc ) - [ ! cache [ class subtree n ] - ! break - diff-cached - [ { - { [ over assoc-empty? ] [ 2drop f ] } - { [ tuple-subtree? ] [ [ over ] 2dip build-tuple-dispatcher ] } - { [ over flat-dispatch? not ] - [ 1 + [ over V{ } clone suffix ] 2dip build-tag-dispatcher ] } - { [ over length 1 = ] [ drop first ] } - { [ over length 1 > ] [ resolve-ambiguity ] } - } cond ] keepd ! cache [ class dispatcher subtree ] - ! push-cache - drop - ] curry assoc-map nip ; - -: make-dispatch ( tree -- dispatcher ) - V{ } clone 1array swap 0 build-tag-dispatcher ; - -! * Compiling the dispatchers -SYMBOL: default-method -SYMBOL: engines -engines [ H{ } clone ] initialize -GENERIC: compile-dispatcher* ( dispatcher -- obj ) -DEFER: flatten-dispatch -DEFER: compile-dispatcher -GENERIC: flatten-dispatch* ( dispatcher -- obj ) -M: object flatten-dispatch* ; -M: tuple-dispatcher flatten-dispatch* - [ flatten-dispatch ] change-assoc ; -M: tag-dispatcher flatten-dispatch* - compile-dispatcher ; - -: flatten-dispatch ( assoc -- assoc ) - [ flatten-dispatch* - ] assoc-map ; - -: compile-dispatcher ( dispatcher -- obj ) - [ flatten-dispatch ] change-assoc - compile-dispatcher* ; - -: multi-mega-cache-quot ( methods n -- quot ) - make-empty-cache \ mega-cache-lookup [ ] 4sequence ; - -: new-dispatcher-word ( dispatcher quotation -- word ) - "dispatch" - engines get [ set-at ] keepd - swap "dispatcher" [ set-word-prop ] keepdd ; - -! ** Tag Dispatcher -! Main type of dispatcher, compiles down to a mega-cache-lookup quotation -M: tag-dispatcher compile-dispatcher* - dup - [ - assoc>> [ [ tag-number ] dip ] assoc-map - num-types get default-method get swap assoc-union! seq>> - ] [ n>> ] bi - multi-mega-cache-quot new-dispatcher-word ; - -! ** Tuple Dispatcher -! Compiles down to a subtree inside the tag dispatcher - -M: tuple-dispatcher compile-dispatcher* - assoc>> echelon-sort ; - -! * Interface -: make-multi-dispatch ( generic -- word engines ) - H{ } clone engines [ - generic-dispatch-tree - make-dispatch - compile-dispatcher engines get - ] with-variable ; - - ! * Dispatch engine implementation ! TODO: check sorting