Compiler fixes

core/compiler/tests/simple.factor

@@ -1,6 +1,6 @@
 USING: compiler.units tools.test kernel kernel.private
 sequences.private math.private math combinators strings
-alien arrays memory ;
+alien arrays memory vocabs parser ;
 IN: compiler.tests
 
 ! Test empty word
@@ -230,3 +230,11 @@ M: f single-combination-test-2 single-combination-test-4 ;
 
 ! Regression
 [ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
+
+! Regression
+10 [
+    [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
+    [ t ] [
+        "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) (  -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+    ] unit-test
+] times

core/cpu/x86/allot/allot.factor

@@ -29,7 +29,7 @@ IN: cpu.x86.allot
     allot-reg POP
     allot-reg cell [+] swap 8 align ADD ;
 
-M: x86.32 %gc ( -- )
+M: x86 %gc ( -- )
     "end" define-label
     temp-reg-1 load-zone-ptr
     temp-reg-2 temp-reg-1 cell [+] MOV

core/inference/class/class.factor

@@ -325,16 +325,15 @@ M: #call-label infer-classes-before ( #call-label -- )
     [ set-value-class* ] 2each ;
 
 M: #return infer-classes-around
+    dup call-next-method
     nested-labels get length 0 > [
         dup param>> nested-labels get peek param>> eq? [
             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
-            classes= [
+            classes= not [
-                drop
-            ] [
                 fixed-point? off
                 [ in-d>> value-classes get extract-keys ] keep
                 set-node-classes
-            ] if
+            ] [ drop ] if
         ] [ drop ] if
     ] [ drop ] if ;
 
@@ -369,5 +368,5 @@ M: object infer-classes-around
 : infer-classes/node ( node existing -- )
     #! Infer classes, using the existing node's class info as a
     #! starting point.
-    [ node-classes ] [ node-literals ] [ node-intervals ] tri
+    [ classes>> ] [ literals>> ] [ intervals>> ] tri
     infer-classes-with ;

core/optimizer/backend/backend.factor

@@ -3,7 +3,7 @@
 USING: arrays generic assocs inference inference.class
 inference.dataflow inference.backend inference.state io kernel
 math namespaces sequences vectors words quotations hashtables
-combinators classes optimizer.def-use ;
+combinators classes optimizer.def-use accessors ;
 IN: optimizer.backend
 
 SYMBOL: class-substitutions
@@ -16,37 +16,32 @@ SYMBOL: optimizer-changed
 
 GENERIC: optimize-node* ( node -- node/t changed? )
 
-: ?union ( assoc/f assoc -- hash )
+: ?union ( assoc assoc/f -- assoc' )
-    over [ assoc-union ] [ nip ] if ;
+    dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
 
-: add-node-literals ( assoc node -- )
+: add-node-literals ( node assoc -- )
-    over assoc-empty? [
+    [ ?union ] curry change-literals drop ;
+
+: add-node-classes ( node assoc -- )
+    [ ?union ] curry change-classes drop ;
+
+: substitute-values ( node assoc -- )
+    dup assoc-empty? [
         2drop
     ] [
-        [ node-literals ?union ] keep set-node-literals
+        {
-    ] if ;
+            [ >r  in-d>> r> substitute-here ]
-
+            [ >r  in-r>> r> substitute-here ]
-: add-node-classes ( assoc node -- )
+            [ >r out-d>> r> substitute-here ]
-    over assoc-empty? [
+            [ >r out-r>> r> substitute-here ]
-        2drop
+        } 2cleave
-    ] [
-        [ node-classes ?union ] keep set-node-classes
-    ] if ;
-
-: substitute-values ( assoc node -- )
-    over assoc-empty? [
-        2drop
-    ] [
-        2dup node-in-d swap substitute-here
-        2dup node-in-r swap substitute-here
-        2dup node-out-d swap substitute-here
-        node-out-r swap substitute-here
     ] if ;
 
 : perform-substitutions ( node -- )
-    class-substitutions get over add-node-classes
+    [   class-substitutions get add-node-classes  ]
-    literal-substitutions get over add-node-literals
+    [ literal-substitutions get add-node-literals ]
-    value-substitutions get swap substitute-values ;
+    [   value-substitutions get substitute-values ]
+    tri ;
 
 DEFER: optimize-nodes
 
@@ -90,18 +85,21 @@ M: node optimize-node* drop t f ;
     #! Not very efficient.
     dupd union* update ;
 
-: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
+: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
-    node-out-d swap node-in-d 2array unify-lengths flip
+    [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
     [ = not ] assoc-subset >hashtable ;
 
 : cleanup-inlining ( #return/#values -- newnode changed? )
-    dup node-successor dup [
+    dup node-successor [
-        class-substitutions get pick node-classes update
+        [ node-successor ] keep
-        literal-substitutions get pick node-literals update
+        {
-        tuck compute-value-substitutions value-substitutions get swap update*
+            [ nip classes>> class-substitutions get swap update ]
-        node-successor t
+            [ nip literals>> literal-substitutions get swap update ]
+            [ compute-value-substitutions value-substitutions get swap update* ]
+            [ drop node-successor ]
+        } 2cleave t
     ] [
-        2drop t f
+        drop t f
     ] if ;
 
 ! #return

core/optimizer/optimizer-tests.factor

@@ -291,7 +291,6 @@ TUPLE: silly-tuple a b ;
 
 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
 
-! Make sure we don't lose
 GENERIC: generic-inline-test ( x -- y )
 M: integer generic-inline-test ;
 
@@ -308,6 +307,7 @@ M: integer generic-inline-test ;
     generic-inline-test
     generic-inline-test ;
 
+! Inlining all of the above should only take two passes
 [ { t f } ] [
     \ generic-inline-test-1 word-def dataflow
     [ optimize-1 , optimize-1 , drop ] { } make