Get compiler going again, start re-doing redefine tests

core/bootstrap/compiler/compiler.factor

@@ -54,4 +54,4 @@ generator command-line vocabs io prettyprint libc ;
     malloc free memcpy
 } compile
 
-[ compile-batch ] recompile-hook set-global
+[ compile ] recompile-hook set-global

core/compiler/compiler.factor

@@ -29,27 +29,34 @@ SYMBOL: compiler-hook
     "compiled-effect" set-word-prop ;
 
 : (compile) ( word -- )
-    dup compiling? not over compound? and [
+    [
-        [
+        dup compile-begins
-            dup compile-begins
+        dup word-dataflow optimize >r over dup r> generate
-            dup word-dataflow optimize >r over dup r> generate
+    ] [
-        ] [
+        print-error f
-            print-error f
+    ] recover
-        ] recover
+    2dup ripple-up save-effect ;
-        2dup ripple-up save-effect
+
-    ] [ drop ] if ;
+: delete-any ( assoc -- element )
+    [ [ 2drop t ] assoc-find 2drop dup ] keep delete-at ;
+
+: compile-loop ( assoc -- )
+    dup assoc-empty?
+    [ drop ] [ dup delete-any (compile) compile-loop ] if ;
 
 : compile ( words -- )
     [
-        <dlist> compile-queue set
+        H{ } clone compile-queue set
-        H{ } clone compiled-xts set
+        H{ } clone compiled set
         [ queue-compile ] each
-        compile-queue get [ (compile) ] dlist-slurp
+        compile-queue get compile-loop
-        compiled-xts get >alist modify-code-heap
+        compiled get >alist modify-code-heap
     ] with-scope ; inline
 
 : compile-quot ( quot -- word )
-    [ define-temp ] with-compilation-unit ;
+    H{ } clone changed-words [
+        define-temp dup 1array compile
+    ] with-variable ;
 
 : compile-call ( quot -- )
     compile-quot execute ;

core/compiler/test/redefine.factor

@@ -3,3 +3,49 @@ namespaces parser tools.test words kernel sequences arrays io
 effects tools.test.inference ;
 IN: temporary
 
+DEFER: b
+DEFER: c
+
+[ ] [ "IN: temporary : a 1 2 ; : b a a ;" eval ] unit-test
+
+[ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test
+
+{ 0 4 } [ b ] unit-test-effect
+
+[ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test
+
+[ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test
+
+{ 0 6 } [ b ] unit-test-effect
+
+\ b word-xt "b-xt" set
+
+[ ] [ "IN: temporary : c b ;" eval ] unit-test
+
+[ t ] [ "b-xt" get \ b word-xt = ] unit-test
+
+\ c word-xt "c-xt" set
+
+[ ] [ "IN: temporary : a 1 2 4 ;" eval ] unit-test
+
+[ t ] [ "c-xt" get \ c word-xt = ] unit-test
+
+[ 1 2 4 1 2 4 ] [ "USE: temporary c" eval ] unit-test
+
+[ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test
+
+{ 0 4 } [ c ] unit-test-effect
+
+[ f ] [ "c-xt" get \ c word-xt = ] unit-test
+
+[ 1 2 1 2 ] [ "USE: temporary c" eval ] unit-test
+
+[ ] [ "IN: temporary : d 3 ; inline" eval ] unit-test
+
+[ ] [ "IN: temporary : e d d ;" eval ] unit-test
+
+[ 3 3 ] [ "USE: temporary e" eval ] unit-test
+
+[ ] [ "IN: temporary : d 4 ; inline" eval ] unit-test
+
+[ 4 4 ] [ "USE: temporary e" eval ] unit-test

core/compiler/test/simple.factor

@@ -3,61 +3,59 @@ combinators.private ;
 IN: temporary
 
 ! Test empty word
-[ ] [ [ ] compile-1 ] unit-test
+[ ] [ [ ] compile-call ] unit-test
 
 ! Test literals
-[ 1 ] [ [ 1 ] compile-1 ] unit-test
+[ 1 ] [ [ 1 ] compile-call ] unit-test
-[ 31 ] [ [ 31 ] compile-1 ] unit-test
+[ 31 ] [ [ 31 ] compile-call ] unit-test
-[ 255 ] [ [ 255 ] compile-1 ] unit-test
+[ 255 ] [ [ 255 ] compile-call ] unit-test
-[ -1 ] [ [ -1 ] compile-1 ] unit-test
+[ -1 ] [ [ -1 ] compile-call ] unit-test
-[ 65536 ] [ [ 65536 ] compile-1 ] unit-test
+[ 65536 ] [ [ 65536 ] compile-call ] unit-test
-[ -65536 ] [ [ -65536 ] compile-1 ] unit-test
+[ -65536 ] [ [ -65536 ] compile-call ] unit-test
-[ "hey" ] [ [ "hey" ] compile-1 ] unit-test
+[ "hey" ] [ [ "hey" ] compile-call ] unit-test
 
 ! Calls
 : no-op ;
 
-[ ] [ [ no-op ] compile-1 ] unit-test
+[ ] [ [ no-op ] compile-call ] unit-test
-[ 3 ] [ [ no-op 3 ] compile-1 ] unit-test
+[ 3 ] [ [ no-op 3 ] compile-call ] unit-test
-[ 3 ] [ [ 3 no-op ] compile-1 ] unit-test
+[ 3 ] [ [ 3 no-op ] compile-call ] unit-test
 
 : bar 4 ;
 
-[ 4 ] [ [ bar no-op ] compile-1 ] unit-test
+[ 4 ] [ [ bar no-op ] compile-call ] unit-test
-[ 4 3 ] [ [ no-op bar 3 ] compile-1 ] unit-test
+[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test
-[ 3 4 ] [ [ 3 no-op bar ] compile-1 ] unit-test
+[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test
 
 [ ] [ no-op ] unit-test
 
 ! Conditionals
 
-[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
+[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
-[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-1 ] unit-test
+[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test
-[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
+[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
-[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-1 ] unit-test
+[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test
 
-[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
+[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
-[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-1 ] unit-test
+[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test
 
-[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test
+[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
-[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-1 ] unit-test
+[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test
 
-[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
+[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
-[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-1 ] unit-test
+[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test
-[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test
+[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-1 ] unit-test
+[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
 
 ! Labels
 
 : recursive ( ? -- ) [ f recursive ] when ; inline
 
-[ ] [ t [ recursive ] compile-1 ] unit-test
+[ ] [ t [ recursive ] compile-call ] unit-test
-
-\ recursive compile
 
 [ ] [ t recursive ] unit-test
 
 ! Make sure error reporting works
 
-[ [ dup ] compile-1 ] unit-test-fails
+[ [ dup ] compile-call ] unit-test-fails
-[ [ drop ] compile-1 ] unit-test-fails
+[ [ drop ] compile-call ] unit-test-fails

core/cpu/x86/32/32.factor

@@ -279,7 +279,7 @@ T{ x86-backend f 4 } compiler-backend set-global
 
 "-no-sse2" cli-args member? [
     "Checking if your CPU supports SSE2..." print flush
-    [ sse2? ] compile-1 [
+    [ sse2? ] compile-call [
         " - yes" print
         "cpu.x86.sse2" require
     ] [

core/generator/generator-docs.factor

@@ -19,13 +19,9 @@ $nl
 
 ABOUT: "generator"
 
-HELP: compiled-xts
+HELP: compiled
 { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
 
-HELP: compiling?
-{ $values { "word" word } { "?" "a boolean" } }
-{ $description "Tests if a word is going to be or already is compiled." } ;
-
 HELP: compiling-word
 { $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
 

core/generator/generator.factor

@@ -4,24 +4,29 @@ USING: arrays assocs classes combinators cpu.architecture
 effects generator.fixup generator.registers generic hashtables
 inference inference.backend inference.dataflow io kernel
 kernel.private layouts math namespaces optimizer prettyprint
-quotations sequences system threads words dlists ;
+quotations sequences system threads words ;
 IN: generator
 
 SYMBOL: compile-queue
-
+SYMBOL: compiled
-SYMBOL: compiled-xts
 
 : 6array 3array >r 3array r> append ;
 
-: finish-compiling ( word literals words rel labels code -- )
+: begin-compiling ( word -- )
-    6array swap compiled-xts get set-at ;
+    f swap compiled get set-at ;
 
-: compiling? ( word -- ? )
+: finish-compiling ( word literals words rel labels code -- )
-    dup compiled-xts get key? swap compiled? ;
+    6array swap compiled get set-at ;
 
 : queue-compile ( word -- )
-    dup f compiled-xts get set-at
+    {
-    compile-queue get push-front ;
+        { [ dup compound? not ] [ drop ] }
+        { [ dup compiled get key? ] [ drop ] }
+        { [ t ] [ dup compile-queue get set-at ] }
+    } cond ;
+
+: maybe-compile ( word -- )
+    dup compiled? [ drop ] [ queue-compile ] if ;
 
 SYMBOL: compiling-word
 
@@ -41,7 +46,7 @@ t compiled-stack-traces? set-global
     literal-table get push ;
 
 : generate-1 ( word label node quot -- )
-    [
+    pick begin-compiling [
         roll compiling-word set
         pick compiling-label set
         init-generator
@@ -124,7 +129,7 @@ M: node generate-node drop iterate-next ;
     } cond ;
 
 : generate-call ( label -- next )
-    dup queue-compile
+    dup maybe-compile
     end-basic-block
     tail-call? [
         %jump f