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* { diff --git a/extra/tuple-arrays/tuple-arrays-docs.factor b/extra/tuple-arrays/tuple-arrays-docs.factor index a90068ed57..d6949eaeac 100644 --- a/extra/tuple-arrays/tuple-arrays-docs.factor +++ b/extra/tuple-arrays/tuple-arrays-docs.factor @@ -1,4 +1,5 @@ -USING: help.syntax help.markup tuple-arrays splitting kernel ; +USING: help.syntax help.markup splitting kernel ; +IN: tuple-arrays HELP: tuple-array { $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. Packed follows the sequence protocol and is implemented using the " { $link groups } " class." } ;