Templates fixes for float vreg allocation

diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor
index 49f883cf912bf71fd6625f66ffe3458a50b574e0..ac370698a2bf19274da95ad5f0ff45ced8c28204 100644 (file)
--- a/library/compiler/generator/templates.factor
+++ b/library/compiler/generator/templates.factor
@@ -103,14 +103,10 @@ SYMBOL: phantom-r
     phantoms [ finalize-height ] 2apply ;
 
 : stack>new-vreg ( loc spec -- vreg )
-    reg-spec>class alloc-reg [ swap %peek ] keep ;
+    spec>vreg [ swap %peek ] keep ;
 
 : vreg>stack ( value loc -- )
-    over loc? [
-        2drop
-    ] [
-        over [ %replace ] [ 2drop ] if
-    ] if ;
+    over loc? over not or [ 2drop ] [ %replace ] if ;
 
 : vregs>stack ( phantom -- )
     [
@@ -144,11 +140,9 @@ SYMBOL: phantom-r
 : finalize-contents ( -- )
     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 
-: end-basic-block ( -- )
-    finalize-contents finalize-heights ;
+: end-basic-block ( -- ) finalize-contents finalize-heights ;
 
-: used-vregs ( -- seq )
-    phantoms append [ vreg? ] subset ;
+: used-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
 
 : (compute-free-vregs) ( used class -- vector )
     dup vregs length reverse [ swap <vreg> ] map-with diff
@@ -160,17 +154,17 @@ SYMBOL: phantom-r
     [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
     drop ;
 
-: additional-vregs# ( seq seq -- n )
+: additional-vregs ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     0 [ 0 max + ] reduce ;
 
-: free-vregs* ( -- int# float# )
+: free-vregs# ( -- int# float# )
     T{ int-regs } free-vregs length
     phantoms [ [ loc? ] subset length ] 2apply + -
     T{ float-regs f 8 } free-vregs length ;
 
 : ensure-vregs ( int# float# -- )
-    compute-free-vregs free-vregs* swapd <= >r <= r> and
+    compute-free-vregs free-vregs# swapd <= >r <= r> and
     [ finalize-contents compute-free-vregs ] unless ;
 
 : (lazy-load) ( spec value -- value )
@@ -191,7 +185,8 @@ SYMBOL: phantom-r
 : compatible-values? ( value template -- ? )
     {
         { [ over loc? ] [ 2drop t ] }
-        { [ dup { f float } memq? ] [ 2drop t ] }
+        { [ dup not ] [ drop [ float-regs? ] is? not ] }
+        { [ dup float eq? ] [ 2drop t ] }
         { [ dup integer? ] [ swap compatible-vreg? ] }
     } cond ;
 
@@ -251,7 +246,7 @@ SYMBOL: +clobber
     dup length swap [ float eq? ] subset length [ - ] keep ;
 
 : guess-vregs ( -- int# float# )
-    +input get { } additional-vregs#
+    +input get { } additional-vregs
     +scratch get [ first ] map requested-vregs >r + r> ;
 
 : alloc-scratch ( -- )

diff --git a/library/test/compiler/float.factor b/library/test/compiler/float.factor
index 01ab401f9d0f809908e064a7e2b4c28d537aab2c..49cb4b51b57ecb3532dbb7ba12a43802d68cf62c 100644 (file)
--- a/library/test/compiler/float.factor
+++ b/library/test/compiler/float.factor
@@ -1,10 +1,12 @@
 IN: temporary
-USING: compiler kernel memory math math-internals test ;
+USING: compiler kernel kernel-internals memory math
+math-internals test ;
 
 [ 5.0 ] [ [ 5.0 ] compile-1 full-gc full-gc full-gc ] unit-test
 [ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-1 ] unit-test
 
 [ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-1 ] unit-test
+[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-1 ] unit-test
 
 [ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-1 ] unit-test
 [ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-1 ] unit-test