Changes to templating system, re-enabled shuffle optimizations

library/compiler/intrinsics.factor

@@ -29,7 +29,7 @@ namespaces sequences words ;
 
 \ slot [
     dup slot@ [
-        { { 0 "obj" } { f "slot" } } { "obj" } [
+        { { 0 "obj" } { value "slot" } } { "obj" } [
             node get slot@ "obj" get %fast-slot ,
         ] with-template
     ] [
@@ -42,7 +42,7 @@ namespaces sequences words ;
 
 \ set-slot [
     dup slot@ [
-        { { 0 "val" } { 1 "obj" } { f "slot" } } { } [
+        { { 0 "val" } { 1 "obj" } { value "slot" } } { } [
             "val" get "obj" get node get slot@ %fast-set-slot ,
         ] with-template
     ] [
@@ -77,14 +77,14 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ getenv [
-    { { f "env" } } { "out" } [
+    { { value "env" } } { "out" } [
         T{ vreg f 0 } "out" set
         "env" get "out" get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
-    { { 0 "value" } { f "env" } } { } [
+    { { 0 "value" } { value "env" } } { } [
         "value" get "env" get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
@@ -95,7 +95,7 @@ namespaces sequences words ;
 
 : binary-in ( node -- in )
     literal-immediate? fixnum-imm? and
-    { { 0 "x" } { f "y" } } { { 0 "x" } { 1 "y" } } ? ;
+    { { 0 "x" } { value "y" } } { { 0 "x" } { 1 "y" } } ? ;
 
 : (binary-op) ( node in -- )
     { "x" } [
@@ -172,7 +172,7 @@ namespaces sequences words ;
 : slow-shift ( -- ) \ fixnum-shift %call , ;
 
 : negative-shift ( n node -- )
-    { { 0 "x" } { f "n" } } { "out" } [
+    { { 0 "x" } { value "n" } } { "out" } [
         dup cell-bits neg <= [
             drop
             T{ vreg f 2 } "out" set
@@ -185,7 +185,7 @@ namespaces sequences words ;
 
 : fast-shift ( n node -- )
     over zero? [
-        -1 0 adjust-stacks end-basic-block 2drop
+        end-basic-block -1 0 adjust-stacks 2drop
     ] [
         over 0 < [
             negative-shift

library/compiler/linearizer.factor

@@ -38,7 +38,7 @@ SYMBOL: renamed-labels
 
 : make-linear ( word quot -- )
     [
-        0 { d-height r-height } [ set ] each-with
+        init-templates
         swap >r { } make r> linearized get set-hash
     ] with-node-iterator ; inline
 
@@ -125,17 +125,11 @@ SYMBOL: live-r
     #! Avoid storing a value into its former position.
     dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
 
-: shuffle-height ( node -- )
-    [ dup node-out-d length swap node-in-d length - ] keep
-    dup node-out-r length swap node-in-r length -
-    adjust-stacks ;
-
 M: #shuffle linearize* ( #shuffle -- )
     0 vreg-allocator set
     dup node-in-d over node-out-d live-stores live-d set
     dup node-in-r over node-out-r live-stores live-r set
-    dup do-inputs
+    do-inputs
-    shuffle-height
     live-d get live-r get template-outputs
     iterate-next ;
 
@@ -145,7 +139,7 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        -1 0 adjust-stacks
+        end-basic-block -1 0 adjust-stacks
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [

library/compiler/templates.factor

@@ -7,30 +7,25 @@ namespaces sequences vectors words ;
 SYMBOL: d-height
 SYMBOL: r-height
 
+! Uncomitted values
+SYMBOL: phantom-d
+SYMBOL: phantom-r
+
+: init-templates
+    0 d-height set 0 r-height set
+    V{ } clone phantom-d set V{ } clone phantom-r set ;
+
 ! A data stack location.
 TUPLE: ds-loc n ;
-
+C: ds-loc [ >r d-height get - r> set-ds-loc-n ] keep ;
-C: ds-loc ( n -- ds-loc ) 
-    [ >r d-height get - r> set-ds-loc-n ] keep ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
-
+C: cs-loc [ >r r-height get - r> set-cs-loc-n ] keep ;
-C: cs-loc ( n -- ds-loc ) 
-    [ >r r-height get - r> set-cs-loc-n ] keep ;
 
 : adjust-stacks ( inc-d inc-r -- )
     r-height [ + ] change d-height [ + ] change ;
 
-: finalize-stack ( quot symbol -- )
-    [
-        get dup zero? [ 2drop ] [ swap execute , ] if 0
-    ] keep set ; inline
-
-: end-basic-block ( -- )
-    \ %inc-r r-height finalize-stack
-    \ %inc-d d-height finalize-stack ;
-
 : immediate? ( obj -- ? )
     #! fixnums and f have a pointerless representation, and
     #! are compiled immediately. Everything else can be moved
@@ -40,73 +35,86 @@ C: cs-loc ( n -- ds-loc )
 : load-literal ( obj vreg -- )
     over immediate? [ %immediate ] [ %indirect ] if , ;
 
-GENERIC: stack>vreg* ( vreg loc value -- operand )
+: literal>stack ( value loc -- )
+    swap value-literal fixnum-imm? over immediate? and
+    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
+    swap %replace , ; inline
 
-M: object stack>vreg* ( vreg loc value -- operand )
+G: vreg>stack ( value loc -- ) 1 standard-combination ;
-    drop >r <vreg> dup r> %peek , ;
 
-M: value stack>vreg* ( vreg loc value -- operand )
+M: f vreg>stack ( value loc -- ) 2drop ;
-    nip value-literal swap <vreg> [ load-literal ] keep ;
+
+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 , ;
+
+M: object vreg>stack ( value loc -- )
+    %replace , ;
+
+: vregs>stack ( values quot literals -- )
+    -rot >r [ dup value? rot eq? [ drop f ] unless ] map-with
+    dup reverse-slice swap length r> map
+    [ vreg>stack ] 2each ; inline
+
+: finalize-height ( word symbol -- )
+    [ dup zero? [ 2drop ] [ swap execute , ] if 0 ] change ;
+    inline
+
+: end-basic-block ( -- )
+    \ %inc-d d-height finalize-height
+    \ %inc-r r-height finalize-height
+    phantom-d get [ <ds-loc> ] f vregs>stack
+    phantom-r get [ <cs-loc> ] f vregs>stack
+    phantom-d get [ <ds-loc> ] t vregs>stack
+    phantom-r get [ <cs-loc> ] t vregs>stack
+    0 phantom-d get set-length
+    0 phantom-r get set-length ;
+
+G: stack>vreg ( value vreg loc -- operand )
+    2 standard-combination ;
+
+M: f stack>vreg ( value vreg loc -- operand ) 2drop ;
+
+M: object stack>vreg ( value vreg loc -- operand )
+    >r <vreg> dup r> %peek , nip ;
+
+M: value stack>vreg ( value vreg loc -- operand )
+    drop >r value-literal r> dup value eq?
+    [ drop ] [ <vreg> [ load-literal ] keep ] if ;
 
 SYMBOL: vreg-allocator
 
 SYMBOL: any-reg
 
-: alloc-value ( loc value -- operand )
+: alloc-reg ( template -- template )
-    vreg-allocator [ inc ] keep get -rot stack>vreg* ;
+    dup any-reg eq? [
+        drop vreg-allocator dup get swap inc
+    ] when ;
 
-: stack>vreg ( vreg loc value -- operand )
+: alloc-regs ( template -- template ) [ alloc-reg ] map ;
-    {
-        { [ dup not ] [ 3drop f ] }
-        { [ pick any-reg eq? ] [ alloc-value nip ] }
-        { [ pick not ] [ 2nip value-literal ] }
-        { [ t ] [ stack>vreg* ] }
-    } cond ;
 
-: (stack>vregs) ( names values template quot -- inputs )
+: (stack>vregs) ( values template locs -- inputs )
-    >r dup length reverse r> map 3array flip
+    3array flip
-    [ first3 rot stack>vreg ] map swap [ set ] 2each ; inline
+    [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
 
 : stack>vregs ( stack template quot -- )
-    >r unpair -rot r> (stack>vregs) ; inline
+    >r unpair -rot alloc-regs dup length reverse r> map
+    (stack>vregs) swap [ set ] 2each ; inline
 
 : template-inputs ( stack template stack template -- )
-    [ <cs-loc> ] stack>vregs [ <ds-loc> ] stack>vregs ;
+    end-basic-block
+    over >r [ <cs-loc> ] stack>vregs
+    over >r [ <ds-loc> ] stack>vregs
+    r> r> [ length neg ] 2apply adjust-stacks ;
 
-: literal>stack ( value stack-pos -- )
+: >phantom ( seq stack -- )
-    swap value-literal fixnum-imm? over immediate? and
+    get swap [ dup value? [ get ] unless ] map nappend ;
-    [ T{ vreg f 0 } load-literal T{ vreg f 0 } ] unless
-    swap %replace , ; inline
-
-: vreg>stack ( value stack-pos -- )
-    {
-        { [ over not ] [ 2drop ] }
-        { [ over value? ] [ literal>stack ] }
-        { [ t ] [ >r get r> %replace , ] }
-    } cond ;
-
-: vregs>stack ( values quot -- )
-    >r dup reverse-slice swap length r> map
-    [ vreg>stack ] 2each ; inline
 
 : template-outputs ( stack stack -- )
-    [ <cs-loc> ] vregs>stack [ <ds-loc> ] vregs>stack ;
+    2dup [ length ] 2apply adjust-stacks
-
+    phantom-r >phantom phantom-d >phantom ;
-SYMBOL: template-height
 
 : with-template ( node in out quot -- )
-    pick length pick length swap - template-height set
+    swap >r >r >r dup node-in-d r> { } { } template-inputs
-    swap >r >r
-    >r dup node-in-d r> { } { } template-inputs
-    template-height get 0 adjust-stacks
     node set r> call r> { } template-outputs ; inline
-
-: literals/computed ( stack -- literals computed )
-    dup [ dup value? [ drop f ] unless ] map
-    swap [ dup value? [ drop f ] when ] map ;
-
-: vregs>stacks ( ds cs -- )
-    #! We store literals last because storing a literal to a
-    #! stack slot actually clobbers a vreg.
-    >r literals/computed r> literals/computed swapd
-    template-outputs template-outputs ;

library/test/compiler/intrinsics.factor

@@ -54,6 +54,8 @@ math-internals sequences strings test words ;
 [ 2 ] [ 1 [ 2 nip ] compile-1 ] unit-test
 [ 2 ] [ 1 2 [ nip ] compile-1 ] unit-test
 
+[ 2 1 "hi" ] [ 1 2 [ swap "hi" ] compile-1 ] unit-test
+
 [ 4 ] [ 12 7 [ fixnum-bitand ] compile-1 ] unit-test
 [ 4 ] [ 12 [ 7 fixnum-bitand ] compile-1 ] unit-test
 [ 4 ] [ [ 12 7 fixnum-bitand ] compile-1 ] unit-test