Register allocator fixes

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index c7cec72b3f8b7e0203cd7dbe505e4dcab1d46356..5826084f08613d7657532b6611cb5234e1a5fc54 100644 (file)
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -68,12 +68,12 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { 0 "in" } } { "in" }
+    { { any-reg "in" } } { "in" }
     [ end-basic-block "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { 0 "in" } } { "in" } [ "in" get %tag , ] with-template
+    { { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 \ getenv [
@@ -84,7 +84,7 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ setenv [
-    { { 0 "value" } { value "env" } } { } [
+    { { any-reg "value" } { value "env" } } { } [
         "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -119,7 +119,7 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( node label op -- )
-    rot dup binary-in { } [
+    rot { { any-reg "x" } { any-reg "y" } } { } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
@@ -185,7 +185,7 @@ namespaces sequences words ;
 
 : fast-shift ( n node -- )
     over zero? [
-        end-basic-block -1 0 adjust-stacks 2drop
+        drop-phantom 2drop
     ] [
         over 0 < [
             negative-shift

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 81bfc41ae0d65468f090f0cd7c2373b9520de08e..6a47323dfa05ab7200cd0578f52cc72dee44af70 100644 (file)
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -111,7 +111,7 @@ M: #call-label linearize* ( node -- next )
     template-inputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    0 vreg-allocator set
+    compute-free-vregs
     node-shuffle dup do-inputs
     dup shuffle-out-d swap shuffle-out-r template-outputs
     iterate-next ;
@@ -122,7 +122,7 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        end-basic-block -1 0 adjust-stacks
+        end-basic-block drop-phantom
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [

diff --git a/library/compiler/ppc/stack.factor b/library/compiler/ppc/stack.factor
index 3e81215eebbb970e8cdaa7ab3d7c1770c3d36847..abba5546634c728fff9d71ad93eb73af11d10bca 100644 (file)
--- a/library/compiler/ppc/stack.factor
+++ b/library/compiler/ppc/stack.factor
@@ -9,14 +9,22 @@ GENERIC: loc>operand
 M: ds-loc loc>operand ds-loc-n cells neg 14 swap ;
 M: cs-loc loc>operand cs-loc-n cells neg 15 swap ;
 
+: %literal ( quot -- )
+    0 output vreg? [
+        0 input 0 output-operand rot call
+    ] [
+        0 input 11 rot call
+        11 0 output loc>operand STW
+    ] if ; inline
+
 M: %immediate generate-node ( vop -- )
-    drop 0 input address 0 output-operand LOAD ;
+    drop [ >r address r> LOAD ] %literal ;
 
 : load-indirect ( dest literal -- )
     add-literal over LOAD32 rel-2/2 rel-address dup 0 LWZ ;
 
 M: %indirect generate-node ( vop -- )
-    drop 0 output-operand 0 input load-indirect ;
+    drop [ swap load-indirect ] %literal ;
 
 M: %peek generate-node ( vop -- )
     drop 0 output-operand 0 input loc>operand LWZ ;

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 1dd68fd9e5b76fc039fc41ffed57c5cd84897bb1..27aa2bc08dedbc1f79e312805dcd662ea90c77b6 100644 (file)
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -49,9 +49,6 @@ M: phantom-callstack <loc> (loc) <cs-loc> ;
 M: phantom-callstack finalize-height
     \ %inc-r (finalize-height) ;
 
-: phantom-append ( seq phantom -- )
-    phantom-stack-elements swap nappend ;
-
 : phantom-locs ( n phantom -- locs )
     swap reverse-slice [ swap <loc> ] map-with ;
 
@@ -61,8 +58,10 @@ M: phantom-callstack finalize-height
 : adjust-phantom ( n phantom -- )
     [ phantom-stack-height + ] keep set-phantom-stack-height ;
 
-: reset-phantom ( phantom -- )
-    0 swap set-length ;
+GENERIC: cut-phantom ( n phantom -- seq )
+
+M: phantom-stack cut-phantom ( n phantom -- seq )
+    [ delegate cut* swap ] keep set-delegate ;
 
 SYMBOL: phantom-d
 SYMBOL: phantom-r
@@ -71,17 +70,13 @@ SYMBOL: phantom-r
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set ;
 
-: adjust-stacks ( inc-d inc-r -- )
-    phantom-r get adjust-phantom
-    phantom-d get adjust-phantom ;
-
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
     #! are compiled immediately. Everything else can be moved
     #! by GC, and is indexed through a table.
     dup fixnum? swap f eq? or ;
 
-: load-literal ( obj vreg -- )
+: load-literal ( obj dest -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
 G: vreg>stack ( value loc -- ) 1 standard-combination ;
@@ -89,27 +84,25 @@ G: vreg>stack ( value loc -- ) 1 standard-combination ;
 M: f vreg>stack ( value loc -- ) 2drop ;
 
 M: value vreg>stack ( value loc -- )
-    swap value-literal fixnum-imm? over immediate? and
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ;
+    >r value-literal r> load-literal ;
 
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
-: vregs>stack ( values? phantom -- )
-    [
-        [ dup value? rot eq? [ drop f ] unless ] map-with
-    ] keep phantom-locs* [ vreg>stack ] 2each ;
+: vregs>stack ( phantom -- )
+    dup dup phantom-locs* [ vreg>stack ] 2each
+    0 swap set-length ;
+
+: finalize-phantom ( phantom -- )
+    dup finalize-height vregs>stack ;
 
 : end-basic-block ( -- )
-    phantom-d get finalize-height
-    phantom-r get finalize-height
-    f phantom-d get vregs>stack
-    f phantom-r get vregs>stack
-    t phantom-d get vregs>stack
-    t phantom-r get vregs>stack
-    phantom-d get reset-phantom
-    phantom-r get reset-phantom ;
+    phantom-d get finalize-phantom
+    phantom-r get finalize-phantom ;
+
+: end-basic-block* ( -- )
+    phantom-d get vregs>stack
+    phantom-r get vregs>stack ;
 
 G: stack>vreg ( value vreg loc -- operand )
     2 standard-combination ;
@@ -126,16 +119,26 @@ M: value stack>vreg ( value vreg loc -- operand )
         >r value-literal r> <vreg> [ load-literal ] keep
     ] if ;
 
-SYMBOL: vreg-allocator
-
 SYMBOL: any-reg
 
-: alloc-reg ( template -- template )
-    dup any-reg eq? [
-        drop vreg-allocator dup get swap inc
-    ] when ;
+SYMBOL: free-vregs
+
+: compute-free-vregs ( -- )
+    phantom-d get [ vreg? ] subset
+    phantom-r get [ vreg? ] subset append
+    [ vreg-n ] map vregs length reverse diff
+    >vector free-vregs set ;
+
+: requested-vregs ( template -- n )
+    [ any-reg eq? ] subset length ;
 
-: alloc-regs ( template -- template ) [ alloc-reg ] map ;
+: sufficient-vregs? ( template template -- ? )
+    [ requested-vregs ] 2apply + free-vregs get length <= ;
+
+: alloc-regs ( template -- template )
+    free-vregs get swap [
+        dup any-reg eq? [ drop pop ] [ nip ] if
+    ] map-with ;
 
 : (stack>vregs) ( values template locs -- inputs )
     3array flip
@@ -145,54 +148,71 @@ SYMBOL: any-reg
     >r [ dup value? [ value-literal ] when ] map
     r> [ second set ] 2each ;
 
-: stack>vregs ( values phantom template -- )
+: stack>vregs ( values phantom template -- values )
     [
         [ first ] map alloc-regs
         pick length rot phantom-locs
         (stack>vregs)
-    ] keep phantom-vregs ;
+    ] 2keep length neg swap adjust-phantom ;
 
 : compatible-vreg? ( value vreg -- ? )
     swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
     {
+        { [ dup not ] [ 2drop t ] }
+        { [ over not ] [ 2drop f ] }
         { [ dup any-reg eq? ] [ drop vreg? ] }
         { [ dup integer? ] [ compatible-vreg? ] }
         { [ dup value eq? ] [ drop value? ] }
-        { [ dup not ] [ 2drop t ] }
     } cond ;
 
-: template-match? ( phantom template -- ? )
-    2dup [ length ] 2apply = [
-        f [ first compatible-values? and ] 2reduce
+: template-match? ( template phantom -- ? )
+    2dup [ length ] 2apply <= [
+        >r dup length r> tail-slice*
+        t [ swap first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;
 
-: optimized-input ( phantom template -- )
-    over >r phantom-vregs r> reset-phantom ;
+: templates-match? ( template template -- ? )
+    2dup sufficient-vregs? [
+        phantom-r get template-match?
+        >r phantom-d get template-match? r> and
+    ] [
+        2drop f
+    ] if ;
+
+: optimized-input ( template phantom -- )
+    over length neg over adjust-phantom
+    over length over cut-phantom
+    >r dup empty? [ drop ] [ vregs>stack ] if r>
+    swap phantom-vregs ;
 
 : template-input ( values template phantom -- )
-    swap 2dup template-match? [
-        optimized-input drop
-    ] [
-        end-basic-block stack>vregs
-    ] if ; inline
+    dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
 
 : template-inputs ( values template values template -- )
-    over >r phantom-r get template-input
-    over >r phantom-d get template-input
-    r> r> [ length neg ] 2apply adjust-stacks ;
+    pick over templates-match? [
+        phantom-r get optimized-input drop
+        phantom-d get optimized-input drop
+    ] [
+        phantom-r get template-input
+        phantom-d get template-input
+    ] if ;
+
+: drop-phantom ( -- )
+    end-basic-block -1 phantom-d get adjust-phantom ;
 
-: (template-outputs) ( seq stack -- )
+: template-output ( seq stack -- )
+    over length over adjust-phantom
     swap [ dup value? [ get ] unless ] map nappend ;
 
 : template-outputs ( stack stack -- )
-    [ [ length ] 2apply adjust-stacks ] 2keep
-    phantom-r get (template-outputs)
-    phantom-d get (template-outputs) ;
+    phantom-r get template-output
+    phantom-d get template-output ;
 
 : with-template ( node in out quot -- )
+    compute-free-vregs
     swap >r >r >r dup node-in-d r> { } { } template-inputs
     node set r> call r> { } template-outputs ; inline

diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index 3bdc393f75a8ecf2d542b68561c6c7366ac6f1b8..a24d9bc4a472a603cc5aaa21ab82252370bbcdfa 100644 (file)
--- a/library/test/compiler/intrinsics.factor
+++ b/library/test/compiler/intrinsics.factor
@@ -2,10 +2,6 @@ IN: temporary
 USING: arrays compiler kernel kernel-internals lists math
 math-internals sequences strings test words ;
 
-! Oops!
-[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
-[ "hi" ] [ [ "hi" ] compile-1 ] unit-test
-
 ! Make sure that intrinsic ops compile to correct code.
 [ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
 [ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test

diff --git a/library/test/compiler/stack.factor b/library/test/compiler/stack.factor
index 463515b0226f14ad906449c96daa666fcee534f2..ed3d27bf2b54949ea6ae40184d38fbb22ffd6942 100644 (file)
--- a/library/test/compiler/stack.factor
+++ b/library/test/compiler/stack.factor
@@ -18,6 +18,3 @@ USING: compiler kernel math-internals test ;
 [ 1 2 1 ] [ 1 2 [ over ] compile-1 ] unit-test
 [ 1 2 3 1 ] [ 1 2 3 [ pick ] compile-1 ] unit-test
 [ 2 1 ] [ 1 2 [ swap ] compile-1 ] unit-test
-
-! Test literals in either side of a shuffle
-[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test

diff --git a/library/test/compiler/templates.factor b/library/test/compiler/templates.factor
new file mode 100644 (file)
index 0000000..068c2df
--- /dev/null
+++ b/library/test/compiler/templates.factor
@@ -0,0 +1,19 @@
+! Black box testing of templater optimization
+
+IN: temporary
+USING: compiler kernel kernel-internals math-internals test ;
+
+! Oops!
+[ 5000 ] [ [ 5000 ] compile-1 ] unit-test
+[ "hi" ] [ [ "hi" ] 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
+
+[ { 1 2 3 } { 1 4 3 } 8 8 ]
+[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-1 ]
+unit-test
+
+! Test literals in either side of a shuffle
+[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test

diff --git a/library/test/test.factor b/library/test/test.factor
index e3fb9d955acc9cb0dff610ba5d054242020e9ea9..9e6c67657e9763cac43713c6f654fc1ed24c1f91 100644 (file)
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -101,7 +101,7 @@ SYMBOL: failures
 : compiler-tests
     {
         "io/buffer"
-        "compiler/simple"
+        "compiler/simple" "compiler/templates"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
         "compiler/linearizer" "compiler/intrinsics"