Register allocator fixes

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

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" } } { } [

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 ;

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 -- )
+GENERIC: cut-phantom ( n phantom -- seq )
-    0 swap set-length ;
+
+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
+    >r value-literal r> load-literal ;
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ;
 
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
-: vregs>stack ( values? phantom -- )
+: vregs>stack ( phantom -- )
-    [
+    dup dup phantom-locs* [ vreg>stack ] 2each
-        [ dup value? rot eq? [ drop f ] unless ] map-with
+    0 swap set-length ;
-    ] keep phantom-locs* [ vreg>stack ] 2each ;
+
+: finalize-phantom ( phantom -- )
+    dup finalize-height vregs>stack ;
 
 : end-basic-block ( -- )
-    phantom-d get finalize-height
+    phantom-d get finalize-phantom
-    phantom-r get finalize-height
+    phantom-r get finalize-phantom ;
-    f phantom-d get vregs>stack
+
-    f phantom-r get vregs>stack
+: end-basic-block* ( -- )
-    t phantom-d get vregs>stack
+    phantom-d get vregs>stack
-    t phantom-r get vregs>stack
+    phantom-r get vregs>stack ;
-    phantom-d get reset-phantom
-    phantom-r get reset-phantom ;
 
 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 )
+SYMBOL: free-vregs
-    dup any-reg eq? [
-        drop vreg-allocator dup get swap inc
-    ] when ;
 
-: alloc-regs ( template -- template ) [ alloc-reg ] map ;
+: 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 ;
+
+: 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 -- ? )
+: template-match? ( template phantom -- ? )
-    2dup [ length ] 2apply = [
+    2dup [ length ] 2apply <= [
-        f [ first compatible-values? and ] 2reduce
+        >r dup length r> tail-slice*
+        t [ swap first compatible-values? and ] 2reduce
     ] [
         2drop f
     ] if ;
 
-: optimized-input ( phantom template -- )
+: templates-match? ( template template -- ? )
-    over >r phantom-vregs r> reset-phantom ;
+    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? [
+    dup vregs>stack swap [ stack>vregs ] keep phantom-vregs ;
-        optimized-input drop
-    ] [
-        end-basic-block stack>vregs
-    ] if ; inline
 
 : template-inputs ( values template values template -- )
-    over >r phantom-r get template-input
+    pick over templates-match? [
-    over >r phantom-d get template-input
+        phantom-r get optimized-input drop
-    r> r> [ length neg ] 2apply adjust-stacks ;
+        phantom-d get optimized-input drop
+    ] [
+        phantom-r get template-input
+        phantom-d get template-input
+    ] if ;
 
-: (template-outputs) ( seq stack -- )
+: drop-phantom ( -- )
+    end-basic-block -1 phantom-d get adjust-phantom ;
+
+: 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-output
-    phantom-r get (template-outputs)
+    phantom-d get template-output ;
-    phantom-d get (template-outputs) ;
 
 : 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

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

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

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

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"