Merge git://factorcode.org/git/factor

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-usage ( word -- assoc )
-    compiled-crossref get at keys ;
+    compiled-crossref get at ;
-
-: sensitive? ( word -- ? )
-    dup "inline" word-prop
-    over "infer" word-prop
-    pick "specializer" word-prop
-    roll generic?
-    or or or ;
 
 : compiled-usages ( words -- seq )
-    compiled-crossref get [
+    [ [ dup ] H{ } map>assoc dup ] keep [
-        [
+        compiled-usage [ nip +inlined+ eq? ] assoc-subset update
-            over dup set
+    ] with each keys ;
-            over sensitive?
-            [ at namespace swap update ] [ 2drop ] if
-        ] curry each
-    ] H{ } make-assoc 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 ;
 

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

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

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 -- )

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 ;

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

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 -- )
+SYMBOL: +inlined+
-    dup dependencies get dup [ set-at ] [ 3drop ] if ;
+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?

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
+inference.dataflow inference.backend inference.state io kernel
-sequences vectors words quotations hashtables combinators
+math namespaces sequences vectors words quotations hashtables
-classes generic.math continuations optimizer.def-use
+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 dup second +inlined+ depends-on
-    [ [ swap remember-method* ] curry each-node ] [ 2drop ] if ;
+    [ 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*
     {

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 <tuple-array> } ". 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." } ;