Loop optimization work in progress

core/alien/compiler/compiler.factor

@@ -398,7 +398,7 @@ TUPLE: callback-context ;
     callback-unwind %unwind ;
 
 : generate-callback ( node -- )
-    dup alien-callback-xt dup rot [
+    dup alien-callback-xt dup [
         init-templates
         %save-word-xt
         %prologue-later
@@ -407,7 +407,7 @@ TUPLE: callback-context ;
             dup wrap-callback-quot %alien-callback
             %callback-return
         ] with-stack-frame
-    ] generate-1 ;
+    ] with-generator ;
 
 M: alien-callback generate-node
     end-basic-block generate-callback iterate-next ;

core/compiler/compiler.factor

@@ -30,7 +30,7 @@ IN: compiler
 
 : compile-succeeded ( word -- effect dependencies )
     [
-        dup word-dataflow >r swap dup r> optimize generate
+        [ word-dataflow optimize ] keep dup generate
     ] computing-dependencies ;
 
 : compile-failed ( word error -- )

core/generator/fixup/fixup.factor

@@ -140,17 +140,19 @@ SYMBOL: literal-table
     V{ } clone relocation-table set
     V{ } clone label-table set ;
 
-: generate-labels ( -- labels )
+: resolve-labels ( labels -- labels' )
-    label-table get [
+    [
         first3 label-offset
         [ "Unresolved label" throw ] unless*
         3array
     ] map concat ;
 
-: fixup ( code -- relocation-table label-table code )
+: fixup ( code -- literals relocation labels code )
     [
         init-fixup
         dup stack-frame-size swap [ fixup* ] each drop
+
+        literal-table get >array
         relocation-table get >array
-        generate-labels
+        label-table get resolve-labels
     ] { } make ;

core/generator/generator-docs.factor

@@ -22,34 +22,35 @@ HELP: compiled
 { $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
 
 HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
 
 HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ;
+{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
 
 HELP: compiled-stack-traces?
 { $values { "?" "a boolean" } }
 { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
 HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
 
-HELP: init-generator
+HELP: begin-compiling
+{ $values { "word" word } { "label" word } }
 { $description "Prepares to generate machine code for a word." } ;
 
-HELP: generate-1
+HELP: with-generator
-{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
 { $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
 
 HELP: generate-node
 { $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
 { $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate-nodes
 { $values { "node" "a dataflow node" } } 
 { $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link generate-1 } "." } ;
+{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate
 { $values { "word" word } { "label" word } { "node" "a dataflow node" } }

core/generator/generator.factor

@@ -11,12 +11,6 @@ IN: generator
 SYMBOL: compile-queue
 SYMBOL: compiled
 
-: begin-compiling ( word -- )
-    f swap compiled get set-at ;
-
-: finish-compiling ( word literals relocation labels code -- )
-    4array swap compiled get set-at ;
-
 : queue-compile ( word -- )
     {
         { [ dup compiled get key? ] [ drop ] }
@@ -32,24 +26,31 @@ SYMBOL: compiling-word
 
 SYMBOL: compiling-label
 
+SYMBOL: compiling-loop?
+
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
 : compiled-stack-traces? ( -- ? ) 36 getenv ;
 
-: init-generator ( -- )
+: begin-compiling ( word label -- )
+    compiling-loop? off
+    compiling-label set
+    compiling-word set
     compiled-stack-traces?
-    compiling-word get  f ?
+    compiling-word get f ?
-    1vector literal-table set ;
+    1vector literal-table set
+    f compiling-word get compiled get set-at ;
 
-: generate-1 ( word label node quot -- )
+: finish-compiling ( literals relocation labels code -- )
-    pick begin-compiling [
+    4array compiling-label get compiled get set-at ;
-        roll compiling-word set
+
-        pick compiling-label set
+: with-generator ( node word label quot -- )
-        init-generator
+    [
-        call
+        >r begin-compiling r>
-        literal-table get >array
+        { } make fixup
-    ] { } make fixup finish-compiling ;
+        finish-compiling
+    ] with-scope ; inline
 
 GENERIC: generate-node ( node -- next )
 
@@ -63,11 +64,11 @@ GENERIC: generate-node ( node -- next )
     current-label-start define-label
     current-label-start resolve-label ;
 
-: generate ( word label node -- )
+: generate ( node word label -- )
     [
         init-generate-nodes
         [ generate-nodes ] with-node-iterator
-    ] generate-1 ;
+    ] with-generator ;
 
 : word-dataflow ( word -- effect dataflow )
     [
@@ -93,23 +94,25 @@ M: node generate-node drop iterate-next ;
 : generate-call ( label -- next )
     dup maybe-compile
     end-basic-block
-    tail-call? [
+    dup compiling-label get eq? compiling-loop? get and [
-        %jump f
+        drop current-label-start get %jump-label f
     ] [
-        0 frame-required
+        tail-call? [
-        %call
+            %jump f
-        iterate-next
+        ] [
+            0 frame-required
+            %call
+            iterate-next
+        ] if
     ] if ;
 
 ! #label
 M: #label generate-node
     dup node-param generate-call >r
-    dup #label-word over node-param rot node-child generate
+    dup node-child over node-param rot #label-word generate
     r> ;
 
 ! #loop
-SYMBOL: compiling-loop?
-
 M: #loop generate-node
     end-basic-block
     [
@@ -118,8 +121,10 @@ M: #loop generate-node
         current-label-start resolve-label
         compiling-loop? on
         node-child generate-nodes
+        end-basic-block
     ] with-scope
-    end-basic-block ;
+    init-templates
+    iterate-next ;
 
 ! #if
 : end-false-branch ( label -- )
@@ -145,12 +150,12 @@ M: #if generate-node
 ! #dispatch
 : dispatch-branch ( node word -- label )
     gensym [
-        rot [
+        [
             copy-templates
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
-        ] generate-1
+        ] with-generator
     ] keep ;
 
 : tail-dispatch? ( node -- ? )
@@ -177,10 +182,10 @@ M: #dispatch generate-node
         generate-dispatch iterate-next
     ] [
         compiling-word get gensym [
-            rot [
+            [
                 init-generate-nodes
                 generate-dispatch
-            ] generate-1
+            ] with-generator
         ] keep generate-call
     ] if ;
 

core/optimizer/optimizer.factor

@@ -12,7 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
-        "detect-loops" get [ dup detect-loops ] when
+        ! dup detect-loops
         dup infer-classes
         optimizer-changed off
         optimize-nodes