Intrinsics cleanups, x86 fixes

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 0fe2437d62f3dc86b1d4d7c502a6be9af6f23b8e..fdd72faddebd42311e719f6fe6a5dff2530075a6 100644 (file)
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -7,7 +7,7 @@ namespaces sequences words ;
 
 \ slot [
     drop
-    { { 0 "obj" } { 1 "n" } } { "obj" } [
+    { { any-reg "obj" } { any-reg "n" } } { "obj" } [
         "obj" %get %untag ,
         "n" %get "obj" %get %slot ,
     ] with-template
@@ -15,24 +15,25 @@ namespaces sequences words ;
 
 \ set-slot [
     drop
-    { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
+    { { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
+    { } [
         "obj" %get %untag ,
         "val" %get "obj" %get "slot" %get %set-slot ,
+        end-basic-block
+        "obj" get %write-barrier ,
     ] with-template
-    end-basic-block
-    T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ char-slot [
     drop
-    { { 0 "n" } { 1 "str" } } { "str" } [
+    { { any-reg "n" } { any-reg "str" } } { "str" } [
         "n" %get "str" %get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
     drop
-    { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
+    { { any-reg "ch" } { any-reg "n" } { any-reg "str" } } { } [
         "ch" %get "str" %get "n" %get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -108,7 +109,7 @@ namespaces sequences words ;
 
 \ fixnum-bitnot [
     drop
-    { { 0 "x" } } { "x" } [
+    { { any-reg "x" } } { "x" } [
         "x" %get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index faaac788d00439ceb95217e06f9caa296075d5ce..aaaa28257dded5cecfa7557b1163d4b55a02f1c9 100644 (file)
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -116,8 +116,7 @@ SYMBOL: live-r
         pick ?nth dupd ( eq? ) 2drop f [ <clean> ] when
     ] 2map nip ;
 
-: linearize-shuffle ( node -- )
-    compute-free-vregs node-shuffle
+: linearize-shuffle ( shuffle -- )
     dup shuffle-in-d over shuffle-out-d
     shuffle-out-template live-d set
     dup shuffle-in-r over shuffle-out-r
@@ -127,11 +126,16 @@ SYMBOL: live-r
     live-d get live-r get template-outputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    linearize-shuffle iterate-next ;
+    node-shuffle linearize-shuffle iterate-next ;
+
+: ensure-vregs ( n -- )
+    sufficient-vregs?
+    [ end-basic-block compute-free-vregs ] unless ;
 
 : linearize-push ( node -- )
     compute-free-vregs
-    >#push< dup length alloc-reg# [ <vreg> ] map
+    >#push< dup length dup ensure-vregs
+    alloc-reg# [ <vreg> ] map
     [ [ load-literal ] 2each ] keep
     phantom-d get phantom-append ;
 

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 0cf8216efcfce19830ca9891ccb99f3f06517806..6070e1f69c815115e92be4aad05e2fe8a652b42a 100644 (file)
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -118,8 +118,10 @@ SYMBOL: free-vregs
 : requested-vregs ( template -- n )
     [ any-reg eq? ] subset length ;
 
-: sufficient-vregs? ( template template -- ? )
-    [ requested-vregs ] 2apply + free-vregs get length <= ;
+: sufficient-vregs? ( n -- ? ) free-vregs get length <= ;
+
+: template-vreg# ( template template -- n )
+    [ requested-vregs ] 2apply + ;
 
 : alloc-regs ( template -- template )
     free-vregs get swap [
@@ -161,7 +163,7 @@ SYMBOL: free-vregs
     ] if ;
 
 : templates-match? ( template template -- ? )
-    2dup sufficient-vregs? [
+    2dup template-vreg# sufficient-vregs? [
         phantom-r get template-match?
         >r phantom-d get template-match? r> and
     ] [
@@ -175,13 +177,17 @@ SYMBOL: free-vregs
     swap phantom-vregs ;
 
 : template-input ( template phantom -- )
-    dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
+    swap [ stack>vregs ] keep phantom-vregs ;
 
 : template-inputs ( template template -- )
     2dup templates-match? [
         phantom-r get optimized-input
         phantom-d get optimized-input
+        compute-free-vregs
     ] [
+        phantom-r get vregs>stack
+        phantom-d get vregs>stack
+        compute-free-vregs
         phantom-r get template-input
         phantom-d get template-input
     ] if ;
@@ -207,6 +213,5 @@ SYMBOL: free-vregs
     phantom-d get template-output ;
 
 : with-template ( in out quot -- )
-    compute-free-vregs swap >r
-    >r { } template-inputs r> call r> { } template-outputs ;
-    inline
+    swap >r >r { } template-inputs
+    r> call r> { } template-outputs ; inline

diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
index bd0235de4d22b527b5611f0d4b15fac5487282b9..5a1ddc5bbc7de9014fce30f4a46590f33db216e6 100644 (file)
--- a/library/test/compiler/templates.factor
+++ b/library/test/compiler/templates.factor
@@ -8,6 +8,8 @@ math-internals namespaces test ;
 [ 5000 ] [ [ 5000 ] compile-1 ] unit-test
 [ "hi" ] [ [ "hi" ] compile-1 ] unit-test
 
+[ 1 2 3 4 ] [ [ 1 2 3 4 ] compile-1 ] unit-test
+
 [ 1 1 ] [ 1 [ dup ] compile-1 ] unit-test
 [ 0 ] [ 3 [ tag ] compile-1 ] unit-test
 [ 0 3 ] [ 3 [ [ tag ] keep ] compile-1 ] unit-test