Fix dead store elimination

TODO.FACTOR.txt

@@ -74,6 +74,7 @@ should fix in 0.82:
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
 - compiled gc check slows things down
+- fix branch folding
 
 + misc:
 

library/compiler/intrinsics.factor

@@ -30,12 +30,12 @@ namespaces sequences words ;
 \ slot [
     dup slot@ [
         { { 0 "obj" } { value "slot" } } { "obj" } [
-            node get slot@ "obj" get %fast-slot ,
+            node %get slot@ "obj" %get %fast-slot ,
         ] with-template
     ] [
         { { 0 "obj" } { 1 "n" } } { "obj" } [
-            "obj" get %untag ,
-            "n" get "obj" get %slot ,
+            "obj" %get %untag ,
+            "n" %get "obj" %get %slot ,
         ] with-template
     ] if
 ] "intrinsic" set-word-prop
@@ -43,12 +43,13 @@ namespaces sequences words ;
 \ set-slot [
     dup slot@ [
         { { 0 "val" } { 1 "obj" } { value "slot" } } { } [
-            "val" get "obj" get node get slot@ %fast-set-slot ,
+            "val" %get "obj" %get node %get slot@
+            %fast-set-slot ,
         ] with-template
     ] [
         { { 0 "val" } { 1 "obj" } { 2 "slot" } } { } [
-            "obj" get %untag ,
-            "val" get "obj" get "slot" get %set-slot ,
+            "obj" %get %untag ,
+            "val" %get "obj" %get "slot" %get %set-slot ,
         ] with-template
     ] if
     end-basic-block
@@ -57,35 +58,35 @@ namespaces sequences words ;
 
 \ char-slot [
     { { 0 "n" } { 1 "str" } } { "str" } [
-        "n" get "str" get %char-slot ,
+        "n" %get "str" %get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
     { { 0 "ch" } { 1 "n" } { 2 "str" } } { } [
-        "ch" get "str" get "n" get %set-char-slot ,
+        "ch" %get "str" %get "n" %get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
     { { any-reg "in" } } { "in" }
-    [ end-basic-block "in" get %type , ] with-template
+    [ end-basic-block "in" %get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { any-reg "in" } } { "in" } [ "in" get %tag , ] with-template
+    { { any-reg "in" } } { "in" } [ "in" %get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 \ getenv [
     { { value "env" } } { "out" } [
         T{ vreg f 0 } "out" set
-        "env" get "out" get %getenv ,
+        "env" %get "out" %get %getenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ setenv [
     { { any-reg "value" } { value "env" } } { } [
-        "value" get "env" get %setenv ,
+        "value" %get "env" %get %setenv ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -99,7 +100,7 @@ namespaces sequences words ;
 
 : (binary-op) ( node in -- )
     { "x" } [
-        end-basic-block >r "y" get "x" get dup r> execute ,
+        end-basic-block >r "y" %get "x" %get dup r> execute ,
     ] with-template ; inline
 
 : binary-op ( node op -- )
@@ -120,7 +121,7 @@ namespaces sequences words ;
 
 : binary-jump ( node label op -- )
     rot { { any-reg "x" } { any-reg "y" } } { } [
-        end-basic-block >r >r "y" get "x" get r> r> execute ,
+        end-basic-block >r >r "y" %get "x" %get r> r> execute ,
     ] with-template ; inline
 
 {
@@ -144,7 +145,7 @@ namespaces sequences words ;
     { { 0 "x" } { 1 "y" } } { "out" } [
         end-basic-block
         T{ vreg f 2 } "out" set
-        "y" get "x" get "out" get %fixnum-mod ,
+        "y" %get "x" %get "out" %get %fixnum-mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -154,14 +155,14 @@ namespaces sequences words ;
         end-basic-block
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
-        "y" get "x" get 2array
-        "rem" get "quo" get 2array %fixnum/mod ,
+        "y" %get "x" %get 2array
+        "rem" %get "quo" %get 2array %fixnum/mod ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
     { { 0 "x" } } { "x" } [
-        "x" get dup %fixnum-bitnot ,
+        "x" %get dup %fixnum-bitnot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
@@ -176,10 +177,10 @@ namespaces sequences words ;
         dup cell-bits neg <= [
             drop
             T{ vreg f 2 } "out" set
-            "x" get "out" get %fixnum-sgn ,
+            "x" %get "out" %get %fixnum-sgn ,
         ] [
-            "x" get "out" set
-            neg "x" get "out" get %fixnum>> ,
+            "x" %get "out" set
+            neg "x" %get "out" %get %fixnum>> ,
         ] if
     ] with-template ;
 

library/compiler/linearizer.factor

@@ -1,13 +1,9 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler
 USING: arrays generic hashtables inference
 kernel math namespaces sequences words ;
+IN: compiler
 
-! On PowerPC and AMD64, we use a stack discipline whereby
-! stack frames are used to hold parameters. We need to compute
-! the stack frame size to compile the prologue on entry to a
-! word.
 GENERIC: stack-reserve*
 
 M: object stack-reserve* drop 0 ;
@@ -102,18 +98,37 @@ M: #call linearize* ( node -- next )
 M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
-: prepare-inputs ( values -- values templates )
+SYMBOL: live-d
+SYMBOL: live-r
+
+: value-dropped? ( value -- ? )
+    dup value?
+    over live-d get member? not
+    rot live-r get member? not and
+    or ;
+
+: shuffle-in-template ( values -- value template )
+    [ dup value-dropped? [ drop f ] when ] map
     dup [ any-reg swap 2array ] map ;
 
-: do-inputs ( shuffle -- )
-    dup shuffle-in-d prepare-inputs
-    rot shuffle-in-r prepare-inputs
-    template-inputs ;
+: shuffle-out-template ( instack outstack -- stack )
+    #! Avoid storing a value into its former position.
+    dup length [
+        pick ?nth dupd eq? [ <clean> ] when
+    ] 2map nip ;
+
+: 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
+    shuffle-out-template live-r set
+    dup shuffle-in-d shuffle-in-template
+    rot shuffle-in-r shuffle-in-template template-inputs
+    live-d get live-r get template-outputs ;
 
 M: #shuffle linearize* ( #shuffle -- )
     compute-free-vregs
-    node-shuffle trim-shuffle dup do-inputs
-    dup shuffle-out-d swap shuffle-out-r template-outputs
+    node-shuffle linearize-shuffle
     iterate-next ;
 
 : ?static-branch ( node -- n )
@@ -127,7 +142,7 @@ M: #if linearize* ( node -- next )
     ] [
         dup { { 0 "flag" } } { } [
             end-basic-block
-            <label> dup "flag" get %jump-t ,
+            <label> dup "flag" %get %jump-t ,
         ] with-template linearize-if
     ] if* ;
 
@@ -135,7 +150,7 @@ M: #if linearize* ( node -- next )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
     dup { { 0 "n" } } { }
-    [ end-basic-block "n" get %dispatch , ] with-template
+    [ end-basic-block "n" %get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )

library/compiler/templates.factor

@@ -10,6 +10,11 @@ TUPLE: ds-loc n ;
 ! A call stack location.
 TUPLE: cs-loc n ;
 
+! A marker for values which are already stored in this location
+TUPLE: clean ;
+
+C: clean [ set-delegate ] keep ;
+
 TUPLE: phantom-stack height ;
 
 C: phantom-stack ( -- stack )
@@ -89,6 +94,8 @@ M: value vreg>stack ( value loc -- )
 M: object vreg>stack ( value loc -- )
     %replace , ;
 
+M: clean vreg>stack ( value loc -- ) 2drop ;
+
 : vregs>stack ( phantom -- )
     dup dup phantom-locs* [ vreg>stack ] 2each
     0 swap set-length ;
@@ -120,9 +127,9 @@ SYMBOL: any-reg
 SYMBOL: free-vregs
 
 : compute-free-vregs ( -- )
-    phantom-d get [ vreg? ] subset
-    phantom-r get [ vreg? ] subset append
-    [ vreg-n ] map vregs length reverse diff
+    phantom-d get phantom-r get append
+    [ vreg? ] subset [ vreg-n ] map
+    vregs length reverse diff
     >vector free-vregs set ;
 
 : requested-vregs ( template -- n )
@@ -138,11 +145,16 @@ SYMBOL: free-vregs
 
 : (stack>vregs) ( values template locs -- inputs )
     3array flip
-    [ first3 over [ stack>vreg ] [ 3drop f ] if ] map ;
+    [ first3 over [ stack>vreg <clean> ] [ 3drop f ] if ] map ;
+
+: ?clean ( obj -- obj )
+    dup clean? [ delegate ] when ;
+
+: %get ( obj -- value )
+    get ?clean dup value? [ value-literal ] when ;
 
 : phantom-vregs ( values template -- )
-    >r [ dup value? [ value-literal ] when ] map
-    r> [ second set ] 2each ;
+    [ second set ] 2each ;
 
 : stack>vregs ( values phantom template -- values )
     [
@@ -155,7 +167,7 @@ SYMBOL: free-vregs
     swap dup value? [ 2drop f ] [ vreg-n = ] if ;
 
 : compatible-values? ( value template -- ? )
-    {
+    >r ?clean r> {
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
         { [ dup any-reg eq? ] [ drop vreg? ] }
@@ -200,9 +212,16 @@ SYMBOL: free-vregs
 : drop-phantom ( -- )
     end-basic-block -1 phantom-d get adjust-phantom ;
 
+: prep-output ( value -- value )
+    {
+        { [ dup value? ] [ ] }
+        { [ dup clean? ] [ delegate dup value? [ get ] unless ] }
+        { [ t ] [ get ?clean ] }
+    } cond ;
+
 : template-output ( seq stack -- )
     over length over adjust-phantom
-    swap [ dup value? [ get ] unless ] map nappend ;
+    swap [ prep-output ] map nappend ;
 
 : template-outputs ( stack stack -- )
     phantom-r get template-output

library/inference/shuffle.factor

@@ -79,26 +79,3 @@ M: shuffle clone ( shuffle -- shuffle )
     [ shuffle-out-d clone ] keep
     shuffle-out-r clone
     <shuffle> ;
-
-SYMBOL: live-d
-SYMBOL: live-r
-
-: value-dropped? ( value -- ? )
-    dup value?
-    over live-d get member? not
-    rot live-r get member? not and
-    or ;
-
-: filter-dropped ( seq -- seq )
-    [ dup value-dropped? [ drop f ] when ] map ;
-
-: live-stores ( instack outstack -- stack )
-    #! Avoid storing a value into its former position.
-    dup length [ pick ?nth dupd eq? [ drop f ] when ] 2map nip ;
-
-: trim-shuffle ( shuffle -- shuffle )
-    dup shuffle-in-d over shuffle-out-d live-stores live-d set
-    dup shuffle-in-r over shuffle-out-r live-stores live-r set
-    dup shuffle-in-d filter-dropped
-    swap shuffle-in-r filter-dropped
-    live-d get live-r get <shuffle> ;

library/test/compiler/templates.factor

@@ -17,3 +17,13 @@ unit-test
 
 ! Test literals in either side of a shuffle
 [ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-1 ] unit-test
+
+: foo ;
+
+[ 4 4 ]
+[ 1/2 [ tag [ foo ] keep ] compile-1 ]
+unit-test
+
+[ 1 2 2 ]
+[ 1/2 [ dup 0 slot swap 1 slot [ foo ] keep ] compile-1 ]
+unit-test

library/tools/describe.factor

@@ -10,8 +10,11 @@ GENERIC: summary ( object -- string )
     0 > "a positive " "a negative " ? ;
 
 M: integer summary
-    dup sign-string over 2 mod zero? "even " "odd " ?
-    rot class word-name append3 ;
+    dup zero? [
+        "a " "zero "
+    ] [
+        dup sign-string over 2 mod zero? "even " "odd " ?
+    ] if rot class word-name append3 ;
 
 M: real summary
     dup sign-string swap class word-name append ;