stack op rewriting cleaned up, #push-immediate/#push-indirect distinction simplifies generator, optimizer fixes

TODO.FACTOR.txt

@@ -10,7 +10,6 @@
 - type inference
 - handle odd base cases, with code after ifte
 - handle recursion with when, when* etc
-- optimizer rewrite stack ops
 - alien-call need special nodes
 
 + linearizer/generator:

library/compiler/generator-x86.factor

@@ -40,31 +40,6 @@ USE: strings
 USE: words
 USE: vectors
 
-: LITERAL ( cell -- )
-    #! Push literal on data stack.
-    4 ESI R+I
-    ESI I>[R] ;
-
-: [LITERAL] ( cell -- )
-    #! Push complex literal on data stack by following an
-    #! indirect pointer.
-    4 ESI R+I
-    EAX [I]>R
-    EAX ESI R>[R] ;
-
-: 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 ;
-
-: compile-literal ( obj -- )
-    dup immediate? [
-        address LITERAL
-    ] [
-        intern-literal [LITERAL]
-    ] ifte ;
-
 : PUSH-DS ( -- )
     #! Push contents of EAX onto datastack.
     4 ESI R+I
@@ -79,7 +54,13 @@ USE: vectors
     #! Call named C function in Factor interpreter executable.
     dlsym-self CALL JUMP-FIXUP ;
 
-#push [ compile-literal ] "generator" set-word-property
+#push-immediate [
+    address  4 ESI R+I  ESI I>[R]
+] "generator" set-word-property
+
+#push-indirect [
+    intern-literal 4 ESI R+I  EAX [I]>R  EAX ESI R>[R]
+] "generator" set-word-property
 
 #call [
     dup postpone-word

library/compiler/linearizer.factor

@@ -32,6 +32,9 @@ USE: stack
 USE: namespaces
 USE: inference
 USE: combinators
+USE: math
+USE: logic
+USE: kernel
 
 ! The linear IR is close to assembly language. It also resembles
 ! Forth code in some sense. It exists so that pattern matching
@@ -40,6 +43,8 @@ USE: combinators
 ! Linear IR nodes. This is in addition to the symbols already
 ! defined in inference vocab.
 
+SYMBOL: #push-immediate
+SYMBOL: #push-indirect
 SYMBOL: #jump-label-t ( branch if top of stack is true )
 SYMBOL: #jump-label ( unconditional branch )
 SYMBOL: #jump ( tail-call )
@@ -66,6 +71,18 @@ SYMBOL: #return-to ( push addr on C stack )
     #! rest is arguments.
     [ (linearize) ] make-list ;
 
+: 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 ;
+
+#push [
+    [ node-param get ] bind
+    dup immediate? #push-immediate #push-indirect ?
+    swons ,
+] "linearizer" set-word-property
+
 : <label> ( -- label )
     gensym ;
 

library/compiler/optimizer.factor

@@ -104,7 +104,7 @@ USE: logic
 : kill-node ( literals node -- )
     #! Remove the literals from the node and , it if it is not a
     #! NOP.
-    "kill-node" [ (kill-node) ] apply-dataflow ;
+    "kill-node" [ nip , ] apply-dataflow ;
 
 : kill-nodes ( literals dataflow -- dataflow )
     #! Remove literals and construct a list.
@@ -120,13 +120,17 @@ USE: logic
         node-param [ [ dupd kill-nodes ] map nip ] change
     ] extend , ;
 
+#push [
+    [ node-param get ] bind ,
+] "scan-literal" set-word-property
+
 #push [
     consumes-literal? not
 ] "can-kill" set-word-property
 
 #push [
-    [ node-param get ] bind ,
+    (kill-node)
-] "scan-literal" set-word-property
+] "kill-node" set-word-property
 
 #label [
     [ node-param get ] bind (scan-literals)
@@ -156,28 +160,30 @@ USE: logic
 #call-label [ 2drop t ] "can-kill" set-word-property
 
 #drop [ 2drop t ] "can-kill" set-word-property
+#drop [ (kill-node) ] "kill-node" set-word-property
 #dup [ 2drop t ] "can-kill" set-word-property
+#dup [ (kill-node) ] "kill-node" set-word-property
 #swap [ 2drop t ] "can-kill" set-word-property
+#swap [ (kill-node) ] "kill-node" set-word-property
 
-: reduce-stack-op ( literals node map -- node )
+: kill-mask ( literals node -- mask )
+    [ node-consume-d get ] bind [
+        dup cons? [ car over contains? ] [ drop f ] ifte
+    ] map nip ;
+
+: reduce-stack-op ( literals node map -- )
     #! If certain values passing through a stack op are being
     #! killed, the stack op can be reduced, in extreme cases
     #! to a no-op.
-    -rot [
+    -rot [ kill-mask swap assoc ] keep
-        node-consume-d get [
+    over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
-            dup cons? [ car over contains? ] [ drop f ] ifte
-        ] map nip
-        swap assoc node-op set
-    ] extend ;
 
 #over [ 2drop t ] "can-kill" set-word-property
 #over [
     [
         [ [ f f ] | #over ]
         [ [ f t ] | #dup ]
-        [ [ t f ] | #nop ]
+    ] reduce-stack-op
-        [ [ t t ] | #nop ]
-    ] reduce-stack-op ,
 ] "kill-node" set-word-property
 
 #pick [ 2drop t ] "can-kill" set-word-property
@@ -187,12 +193,10 @@ USE: logic
         [ [ f f t ] | #over ]
         [ [ f t f ] | #over ]
         [ [ f t t ] | #dup ]
-        [ [ t f f ] | #nop ]
+    ] reduce-stack-op
-        [ [ t f t ] | #nop ]
-        [ [ t t f ] | #nop ]
-        [ [ t t t ] | #nop ]
-    ] reduce-stack-op ,
 ] "kill-node" set-word-property
 
 #>r [ 2drop t ] "can-kill" set-word-property
+#>r [ (kill-node) ] "kill-node" set-word-property
 #r> [ 2drop t ] "can-kill" set-word-property
+#r> [ (kill-node) ] "kill-node" set-word-property

library/lists.factor

@@ -47,7 +47,7 @@ USE: vectors
     #! from first occurrence where it is true, or return f.
     over [
         dup >r over >r >r car r> call [
-            r> r> 2drop t
+            r> r> drop
         ] [
             r> cdr r> some?
         ] ifte
@@ -57,7 +57,7 @@ USE: vectors
 
 : contains? ( element list -- ? )
     #! Test if a list contains an element.
-    [ over = ] some? nip ;
+    [ over = ] some? >boolean nip ;
 
 : nth ( n list -- list[n] )
     #! nth element of a proper list.

library/test/compiler/stack.factor

@@ -35,3 +35,18 @@ USE: math
     [ + ] dup over 3drop ;
 
 [ ] [ kill-3 ] unit-test
+
+: kill-4
+    [ 1 2 3 ] [ + ] [ - ] pick >r 2drop r> ; compiled
+
+[ [ 1 2 3 ] [ 1 2 3 ] ] [ kill-4 ] unit-test
+
+: kill-5
+    [ + ] [ - ] [ 1 2 3 ] pick pick 2drop >r 2drop r> ; compiled
+
+[ [ 1 2 3 ] ] [ kill-5 ] unit-test
+
+: kill-6
+    [ 1 2 3 ] [ 4 5 6 ] [ + ] pick >r drop r> ; compiled
+
+[ [ 1 2 3 ] [ 4 5 6 ] [ 1 2 3 ] ] [ kill-6 ] unit-test