diff --git a/factor/ExternalFactor.java b/factor/ExternalFactor.java index 3c94bfffac..65717fb3d1 100644 --- a/factor/ExternalFactor.java +++ b/factor/ExternalFactor.java @@ -184,9 +184,11 @@ public class ExternalFactor extends DefaultVocabularyLookup */ public synchronized FactorWord makeWord(Cons info) { - FactorWord w = new FactorWord( - (String)info.car, - (String)info.next().car); + String vocabulary = (String)info.car; + String name = (String)info.next().car; + FactorWord w = super.searchVocabulary(new Cons(vocabulary,null),name); + if(w == null) + w = new FactorWord(vocabulary,name); w.stackEffect = (String)info.next().next().car; return w; } //}}} diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor index 3f480256f4..549b81f851 100644 --- a/library/compiler/optimizer.factor +++ b/library/compiler/optimizer.factor @@ -55,23 +55,23 @@ USE: prettyprint #! Collect all literals from all branches. [ node-param get ] bind [ [ scan-literal ] each ] each ; -: mentions-literal? ( literal list -- ) +: mentions-literal? ( literal list -- ? ) #! Does the given list of result objects refer to this #! literal? - [ dup cons? [ car over = ] [ drop f ] ifte ] some? ; + [ dupd value= ] some? nip ; : consumes-literal? ( literal node -- ? ) #! Does the dataflow node consume the literal? [ - node-consume-d get mentions-literal? swap - node-consume-r get mentions-literal? nip or + dup node-consume-d get mentions-literal? swap + dup node-consume-r get mentions-literal? nip or ] bind ; : produces-literal? ( literal node -- ? ) #! Does the dataflow node produce the literal? [ - node-produce-d get mentions-literal? swap - node-produce-r get mentions-literal? nip or + dup node-produce-d get mentions-literal? swap + dup node-produce-r get mentions-literal? nip or ] bind ; : (can-kill?) ( literal node -- ? ) @@ -187,16 +187,16 @@ USE: prettyprint #swap [ 2drop t ] "can-kill" set-word-property #swap [ kill-node ] "kill-node" set-word-property -: kill-mask ( literals node -- mask ) - [ node-consume-d get ] bind [ - dup cons? [ car over contains? ] [ drop f ] ifte - ] map nip ; +: kill-mask ( killing inputs -- mask ) + [ over [ over value= ] some? >boolean nip ] map nip ; : reduce-stack-op ( literals node map -- ) #! If certain values passing through a stack op are being #! killed, the stack op can be reduced, in extreme cases #! to a no-op. - -rot [ kill-mask swap assoc ] keep + -rot [ + [ node-consume-d get ] bind kill-mask swap assoc + ] keep over [ [ node-op set ] extend , ] [ 2drop ] ifte ; #over [ 2drop t ] "can-kill" set-word-property diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 249533ef9f..8d833c0ceb 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -51,7 +51,7 @@ USE: hashtables : unify-result ( obj obj -- obj ) #! Replace values with unknown result if they differ, #! otherwise retain them. - 2dup = [ drop ] [ 2drop gensym ] ifte ; + 2dup = [ drop ] [ 2drop ] ifte ; : unify-stacks ( list -- stack ) #! Replace differing literals in stacks with unknown @@ -85,13 +85,13 @@ USE: hashtables "Unbalanced branches" throw ] ifte ; -: infer-branch ( rstate quot save-effect -- namespace ) +: infer-branch ( value save-effect -- namespace ) [ save-effect set - swap recursive-state set + dup value-recursion recursive-state set copy-interpreter dataflow-graph off - infer-quot + literal infer-quot #values values-node ] extend ; @@ -99,9 +99,9 @@ USE: hashtables #! This is a hack. undefined-method has a stack effect that #! probably does not match any other branch of the generic, #! so we handle it specially. - \ undefined-method swap tree-contains? ; + literal \ undefined-method swap tree-contains? ; -: recursive-branch ( rstate quot -- ) +: recursive-branch ( value -- ) #! Set base case if inference didn't fail. [ f infer-branch [ @@ -109,13 +109,13 @@ USE: hashtables recursive-state get set-base ] bind ] [ - [ 2drop ] when + [ drop ] when ] catch ; : infer-base-case ( branchlist -- ) [ - unswons dup terminator? [ - 2drop + dup terminator? [ + drop ] [ recursive-branch ] ifte @@ -123,7 +123,7 @@ USE: hashtables : (infer-branches) ( branchlist -- list ) dup infer-base-case [ - unswons dup terminator? [ + dup terminator? [ t infer-branch [ meta-d off meta-r off d-in off ] extend @@ -153,8 +153,9 @@ USE: hashtables \ ifte [ infer-ifte ] "infer" set-word-property -: vtable>list ( [ vtable | rstate ] -- list ) - unswons vector>list [ over cons ] map nip ; +: vtable>list ( value -- list ) + dup value-recursion swap literal vector>list + [ over ] map nip ; : infer-dispatch ( -- ) #! Infer effects for all branches, unify. diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 6e0584ba08..ace10181e8 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -36,6 +36,7 @@ USE: strings USE: vectors USE: words USE: hashtables +USE: generic ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs @@ -62,12 +63,42 @@ SYMBOL: recursive-label ! inferred. SYMBOL: save-effect -: gensym-vector ( n -- vector ) - dup swap [ gensym over vector-push ] times ; +! A value has the following slots: + +! the literal object, if any. +SYMBOL: value + +! value-type -- the type, if known. +SYMBOL: value-type + +GENERIC: literal ( value -- obj ) +GENERIC: value= ( literal value -- ? ) + +TRAITS: computed-value +C: computed-value ( -- value ) + [ gensym value set ] extend ; +M: computed-value literal ( value -- obj ) + "Cannot use a computed value literally." throw ; +M: computed-value value= ( literal value -- ? ) + 2drop f ; + +TRAITS: literal-value +C: literal-value ( obj rstate -- value ) + [ recursive-state set value set ] extend ; +M: literal-value literal ( value -- obj ) + [ value get ] bind ; +M: literal-value value= ( literal value -- ? ) + literal = ; + +: value-recursion ( value -- rstate ) + [ recursive-state get ] bind ; + +: computed-value-vector ( n -- vector ) + [ drop ] vector-project ; : add-inputs ( count stack -- stack ) #! Add this many inputs to the given stack. - >r gensym-vector dup r> vector-append ; + >r computed-value-vector dup r> vector-append ; : ensure ( count stack -- count stack ) #! Ensure stack has this many elements. Return number of @@ -88,7 +119,7 @@ SYMBOL: save-effect : produce-d ( count -- ) #! Push count of unknown results. - [ gensym push-d ] times ; + [ push-d ] times ; : effect ( -- [ in | out ] ) #! After inference is finished, collect information. @@ -111,7 +142,7 @@ DEFER: apply-word : apply-literal ( obj -- ) #! Literals are annotated with the current recursive #! state. - dup recursive-state get cons push-d + dup recursive-state get push-d #push dataflow, [ 1 0 node-outputs ] bind ; : apply-object ( obj -- ) diff --git a/library/inference/words.factor b/library/inference/words.factor index d067da19d9..da0db56d1d 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -178,11 +178,13 @@ USE: prettyprint ] ifte ] ifte ; -: infer-call ( [ rstate | quot ] -- ) +: infer-call ( -- ) 1 ensure-d dataflow-drop, gensym dup [ - drop pop-d uncons recursive-state set infer-quot + drop pop-d dup + value-recursion recursive-state set + literal infer-quot ] with-block ; \ call [ infer-call ] "infer" set-word-property diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor index 15ab4a204c..6bf3a094c4 100644 --- a/library/test/compiler/optimizer.factor +++ b/library/test/compiler/optimizer.factor @@ -5,6 +5,7 @@ USE: inference USE: words USE: math USE: kernel +USE: lists : foo 1 2 3 ; @@ -15,3 +16,5 @@ USE: kernel [ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test [ [ [ 1 ] [ 2 ] ] ] [ [ t [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test + +[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f ] map kill-mask ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index aa037e2efb..57f5b0fee3 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -25,7 +25,7 @@ USE: math-internals ! dup [ 7 | 7 ] decompose compose [ 7 | 7 ] = ! ] all? ! ] unit-test -[ 6 ] [ 6 gensym-vector vector-length ] unit-test +[ 6 ] [ 6 computed-value-vector vector-length ] unit-test [ 3 ] [ [ { 1 2 } { 1 2 3 } ] longest-vector ] unit-test diff --git a/library/test/strings.factor b/library/test/strings.factor index 1e06d37e33..177bd87fbe 100644 --- a/library/test/strings.factor +++ b/library/test/strings.factor @@ -6,9 +6,6 @@ USE: namespaces USE: strings USE: test -[ f ] [ "a" "b" "c" =? ] unit-test -[ "c" ] [ "a" "a" "c" =? ] unit-test - [ f ] [ "A string." f-or-"" ] unit-test [ t ] [ "" f-or-"" ] unit-test [ t ] [ f f-or-"" ] unit-test