diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index af0ac8ac89..784104d57f 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -13,33 +13,22 @@ compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) 2dup "compiled-uses" set-word-prop - compiled-crossref get add-vertex ; + compiled-crossref get add-vertex* ; : compiled-unxref ( word -- ) dup "compiled-uses" word-prop - compiled-crossref get remove-vertex ; + compiled-crossref get remove-vertex* ; -: compiled-usage ( word -- seq ) - compiled-crossref get at keys ; - -: sensitive? ( word -- ? ) - dup "inline" word-prop - over "infer" word-prop - pick "specializer" word-prop - roll generic? - or or or ; +: compiled-usage ( word -- assoc ) + compiled-crossref get at ; : compiled-usages ( words -- seq ) - compiled-crossref get [ - [ - over dup set - over sensitive? - [ at namespace swap update ] [ 2drop ] if - ] curry each - ] H{ } make-assoc keys ; + [ [ dup ] H{ } map>assoc dup ] keep [ + compiled-usage [ nip +inlined+ eq? ] assoc-subset update + ] with each keys ; : ripple-up ( word -- ) - compiled-usage [ queue-compile ] each ; + compiled-usage [ drop queue-compile ] assoc-each ; : save-effect ( word effect -- ) over "compiled-uses" word-prop [ @@ -60,7 +49,6 @@ compiled-crossref global [ H{ } assoc-like ] change-at ] computing-dependencies ; : compile-failed ( word error -- ) - ! dup inference-error? [ rethrow ] unless f pick compiled get set-at swap compiler-error ; diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index d9ba349cc2..821daef203 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -92,7 +92,7 @@ DEFER: x-4 [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test -[ t ] [ \ x-3 "compiled-uses" word-prop [ interned? ] all? ] unit-test +[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test DEFER: g-test-1 @@ -190,3 +190,18 @@ DEFER: inline-then-not-inline-test-2 [ f ] [ \ inline-then-not-inline-test-2 word-xt "a" get = ] unit-test [ 6 6 9 ] [ inline-then-not-inline-test-2 ] unit-test + +DEFER: generic-then-not-generic-test-1 +DEFER: generic-then-not-generic-test-2 + +[ ] [ "IN: temporary GENERIC: generic-then-not-generic-test-1 ( a -- b )" eval ] unit-test + +[ ] [ "IN: temporary USE: math M: integer generic-then-not-generic-test-1 sq ;" eval ] unit-test + +[ ] [ "IN: temporary : generic-then-not-generic-test-2 3 generic-then-not-generic-test-1 ;" eval ] unit-test + +[ 9 ] [ generic-then-not-generic-test-2 ] unit-test + +[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test + +[ 4 ] [ generic-then-not-generic-test-2 ] unit-test diff --git a/core/graphs/graphs-tests.factor b/core/graphs/graphs-tests.factor index c68ecca3d9..90b0e93b7c 100644 --- a/core/graphs/graphs-tests.factor +++ b/core/graphs/graphs-tests.factor @@ -16,3 +16,35 @@ H{ [ { 2 3 4 5 } ] [ 2 [ "g" get at ] closure keys natural-sort ] unit-test + +H{ } "g" set + +[ ] [ + "mary" + H{ { "billy" "one" } { "joey" "two" } } + "g" get add-vertex* +] unit-test + +[ H{ { "mary" "one" } } ] [ + "billy" "g" get at +] unit-test + +[ ] [ + "liz" + H{ { "billy" "four" } { "fred" "three" } } + "g" get add-vertex* +] unit-test + +[ H{ { "mary" "one" } { "liz" "four" } } ] [ + "billy" "g" get at +] unit-test + +[ ] [ + "mary" + H{ { "billy" "one" } { "joey" "two" } } + "g" get remove-vertex* +] unit-test + +[ H{ { "liz" "four" } } ] [ + "billy" "g" get at +] unit-test diff --git a/core/graphs/graphs.factor b/core/graphs/graphs.factor index 853589532d..973d49f1fa 100644 --- a/core/graphs/graphs.factor +++ b/core/graphs/graphs.factor @@ -16,9 +16,25 @@ SYMBOL: graph : add-vertex ( vertex edges graph -- ) [ [ dupd nest set-at ] with each ] if-graph ; inline +: (add-vertex) ( key value vertex -- ) + rot nest set-at ; + +: add-vertex* ( vertex edges graph -- ) + [ + swap [ (add-vertex) ] curry assoc-each + ] if-graph ; inline + : remove-vertex ( vertex edges graph -- ) [ [ graph get at delete-at ] with each ] if-graph ; inline +: (remove-vertex) ( key value vertex -- ) + rot graph get at delete-at drop ; + +: remove-vertex* ( vertex edges graph -- ) + [ + swap [ (remove-vertex) ] curry assoc-each + ] if-graph ; inline + SYMBOL: previous : (closure) ( obj quot -- ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 3afbe3bc8e..cf2d021430 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -76,7 +76,8 @@ GENERIC: apply-object ( obj -- ) M: object apply-object apply-literal ; -M: wrapper apply-object wrapped dup depends-on apply-literal ; +M: wrapper apply-object + wrapped dup +called+ depends-on apply-literal ; : terminate ( -- ) terminated? on #terminate node, ; @@ -372,6 +373,7 @@ TUPLE: effect-error word effect ; : custom-infer ( word -- ) #! Customized inference behavior + dup +inlined+ depends-on "infer" word-prop call ; : cached-infer ( word -- ) @@ -449,10 +451,12 @@ M: #call-label collect-recursion* ] if ; M: word apply-object - dup depends-on [ + [ + dup +inlined+ depends-on dup inline-recursive-label [ declared-infer ] [ inline-word ] if ] [ + dup +called+ depends-on dup recursive-label [ declared-infer ] [ apply-word ] if ] if-inline ; diff --git a/core/inference/state/state-tests.factor b/core/inference/state/state-tests.factor new file mode 100644 index 0000000000..e9c31171ed --- /dev/null +++ b/core/inference/state/state-tests.factor @@ -0,0 +1,25 @@ +IN: temporary +USING: tools.test inference.state ; + +SYMBOL: a +SYMBOL: b + +[ ] [ a +called+ depends-on ] unit-test + +[ H{ { a +called+ } } ] [ + [ a +called+ depends-on ] computing-dependencies +] unit-test + +[ H{ { a +called+ } { b +inlined+ } } ] [ + [ + a +called+ depends-on b +inlined+ depends-on + ] computing-dependencies +] unit-test + +[ H{ { a +inlined+ } { b +inlined+ } } ] [ + [ + a +inlined+ depends-on + a +called+ depends-on + b +inlined+ depends-on + ] computing-dependencies +] unit-test diff --git a/core/inference/state/state.factor b/core/inference/state/state.factor index f1b2bff316..cf11ffc88a 100755 --- a/core/inference/state/state.factor +++ b/core/inference/state/state.factor @@ -31,11 +31,16 @@ SYMBOL: current-node ! Words that the current dataflow IR depends on SYMBOL: dependencies -: depends-on ( word -- ) - dup dependencies get dup [ set-at ] [ 3drop ] if ; +SYMBOL: +inlined+ +SYMBOL: +called+ + +: depends-on ( word how -- ) + swap dependencies get dup [ + 2dup at +inlined+ eq? [ 3drop ] [ set-at ] if + ] [ 3drop ] if ; : computing-dependencies ( quot -- dependencies ) - H{ } clone [ dependencies rot with-variable ] keep keys ; + H{ } clone [ dependencies rot with-variable ] keep ; inline ! Did the current control-flow path throw an error? diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9332f31902..1122d83129 100644 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs inference inference.class -inference.dataflow inference.backend io kernel math namespaces -sequences vectors words quotations hashtables combinators -classes generic.math continuations optimizer.def-use +inference.dataflow inference.backend inference.state io kernel +math namespaces sequences vectors words quotations hashtables +combinators classes generic.math continuations optimizer.def-use optimizer.pattern-match generic.standard ; IN: optimizer.backend @@ -173,8 +173,8 @@ M: node remember-method* 2drop ; : remember-method ( method-spec node -- ) - swap dup - [ [ swap remember-method* ] curry each-node ] [ 2drop ] if ; + swap dup second +inlined+ depends-on + [ swap remember-method* ] curry each-node ; : (splice-method) ( #call method-spec quot -- node ) #! Must remember the method before splicing in, otherwise @@ -184,7 +184,10 @@ M: node remember-method* [ swap infer-classes/node ] 2keep [ substitute-node ] keep ; -: splice-quot ( #call quot -- node ) f swap (splice-method) ; +: splice-quot ( #call quot -- node ) + over node-in-d dataflow-with + [ swap infer-classes/node ] 2keep + [ substitute-node ] keep ; : drop-inputs ( node -- #shuffle ) node-in-d clone \ #shuffle in-node ; @@ -358,7 +361,8 @@ M: #dispatch optimize-node* ] if ; : optimistic-inline ( #call -- node ) - dup node-param word-def splice-quot ; + dup node-param dup +inlined+ depends-on + word-def splice-quot ; M: #call optimize-node* {