Register allocation fixes

library/compiler/intrinsics.factor

@@ -17,7 +17,7 @@ namespaces sequences words ;
     { } [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
-        end-basic-block
+        finalize-contents
         "obj" get %write-barrier ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -36,7 +36,7 @@ namespaces sequences words ;
 
 \ type [
     { { any-reg "in" } } { "in" }
-    [ end-basic-block "in" get %type , ] with-template
+    [ finalize-contents "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
@@ -46,7 +46,7 @@ namespaces sequences words ;
 
 : binary-op ( op -- )
     { { 0 "x" } { 1 "y" } } { "x" } [
-        end-basic-block >r "y" get "x" get dup r> execute ,
+        finalize-contents >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
 {
@@ -83,7 +83,7 @@ namespaces sequences words ;
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     { { 0 "x" } { 1 "y" } } { "out" } [
-        end-basic-block
+        finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
     ] with-template
@@ -92,7 +92,7 @@ namespaces sequences words ;
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
-        end-basic-block
+        finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array

library/compiler/linearizer.factor

@@ -98,20 +98,6 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-: ensure-vregs ( n -- )
-    sufficient-vregs?
-    [ end-basic-block compute-free-vregs ] unless ;
-
-: linearize-push ( node -- )
-    compute-free-vregs
-    >#push< dup length dup ensure-vregs
-    alloc-reg# [ <vreg> ] map
-    [ [ load-literal ] 2each ] keep
-    phantom-d get phantom-append ;
-
-M: #push linearize* ( #push -- )
-    linearize-push iterate-next ;
-
 M: #if linearize* ( node -- next )
     { { 0 "flag" } } { } [
         end-basic-block

library/compiler/stack.factor

@@ -20,18 +20,24 @@ namespaces prettyprint sequences vectors words ;
     dup shuffle-in-d length neg phantom-d get adjust-phantom
     shuffle-in-r length neg phantom-r get adjust-phantom ;
 
-: sufficient-shuffle-vregs? ( shuffle -- ? )
-    dup shuffle-in-d length phantom-d get length - 0 max
-    over shuffle-in-r length phantom-r get length - 0 max +
-    free-vregs get length <= ;
+: shuffle-vregs# ( shuffle -- n )
+    dup shuffle-in-d swap shuffle-in-r additional-vregs# ;
 
 : phantom-shuffle ( shuffle -- )
-    compute-free-vregs sufficient-shuffle-vregs? [
-        end-basic-block compute-free-vregs
-    ] unless
+    dup shuffle-vregs# ensure-vregs
     [ phantom-shuffle-inputs ] keep
     [ shuffle* ] keep adjust-shuffle
     (template-outputs) ;
 
 M: #shuffle linearize* ( #shuffle -- )
     node-shuffle phantom-shuffle iterate-next ;
+
+: linearize-push ( node -- )
+    compute-free-vregs
+    >#push< dup length dup ensure-vregs
+    alloc-reg# [ <vreg> ] map
+    [ [ load-literal ] 2each ] keep
+    phantom-d get phantom-append ;
+
+M: #push linearize* ( #push -- )
+    linearize-push iterate-next ;

library/compiler/templates.factor

@@ -127,6 +127,8 @@ SYMBOL: phantom-r
         2drop
     ] if ;
 
+: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
+
 : flush-locs ( phantom phantom -- )
     [
         2dup live-locs \ live-locs set
@@ -134,8 +136,7 @@ SYMBOL: phantom-r
     ] with-scope ;
 
 : finalize-contents ( -- )
-    phantom-d get phantom-r get
-    2dup flush-locs vregs>stack vregs>stack ;
+    phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 
 : end-basic-block ( -- )
     finalize-contents finalize-heights ;
@@ -143,8 +144,7 @@ SYMBOL: phantom-r
 SYMBOL: any-reg
 
 : used-vregs ( -- seq )
-    phantom-d get phantom-r get append
-    [ vreg? ] subset [ vreg-n ] map ;
+    phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
 : compute-free-vregs ( -- )
     used-vregs vregs length reverse diff
@@ -153,8 +153,6 @@ SYMBOL: any-reg
 : requested-vregs ( template -- n )
     [ any-reg eq? ] subset length ;
 
-: sufficient-vregs? ( n -- ? ) free-vregs get length <= ;
-
 : template-vreg# ( template template -- n )
     [ requested-vregs ] 2apply + ;
 
@@ -164,6 +162,18 @@ SYMBOL: any-reg
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
 
+: additional-vregs# ( seq seq -- n )
+    2array phantoms 2array [ [ length ] map ] 2apply v-
+    0 [ 0 max + ] reduce ;
+
+: free-vregs* ( -- n )
+    free-vregs get length
+    phantoms [ [ loc? ] subset length ] 2apply + - ;
+
+: ensure-vregs ( n -- )
+    compute-free-vregs free-vregs* <=
+    [ finalize-contents compute-free-vregs ] unless ;
+
 : lazy-load ( value loc -- value )
     over loc?
     [ dupd = [ drop f ] [ stack>new-vreg ] if ] [ drop ] if ;
@@ -227,15 +237,12 @@ SYMBOL: any-reg
     used-vregs free-vregs [ diff ] change ;
 
 : template-inputs ( template template -- )
-    compute-free-vregs
+    2dup additional-vregs# ensure-vregs
     match-templates fast-input
     adjust-free-vregs
     finalize-contents
     slow-input ;
 
-: drop-phantom ( -- )
-    end-basic-block -1 phantom-d get adjust-phantom ;
-
 : phantom-append ( seq stack -- )
     over length over adjust-phantom swap nappend ;
 

library/test/compiler/templates.factor

@@ -16,6 +16,8 @@ math-internals namespaces test ;
 
 [ 2 3 ] [ 3 [ 2 swap ] compile-1 ] unit-test
 
+[ 2 1 3 4 ] [ 1 2 [ swap 3 4 ] compile-1 ] unit-test
+
 [ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-1 ] unit-test
 
 [ { 1 2 3 } { 1 4 3 } 3 3 ]