more work on optimizer

TODO.FACTOR.txt

@@ -10,8 +10,12 @@
 - type inference
 - handle odd base cases, with code after ifte
 - handle recursion with when, when* etc
-- lifting
-- stack ops and alien-call need special nodes
+- optimizer rewrite stack ops
+- optimizer nested ifte
+- optimizer recursive call
+- dataflow make block nodes for inlined words
+- dataflow recursive calls marked as so
+- alien-call need special nodes
 
 + linearizer/generator:
 

library/compiler/linearizer.factor

@@ -36,19 +36,19 @@ USE: combinators
 ! Linear IR nodes. This is in addition to the symbols already
 ! defined in dataflow vocab.
 
-SYMBOL: #branch-t ( branch if top of stack is true )
-SYMBOL: #branch ( unconditional branch )
-SYMBOL: #label ( branch target )
+SYMBOL: #jump-label-t ( branch if top of stack is true )
+SYMBOL: #jump-label ( unconditional branch )
 SYMBOL: #jump ( tail-call )
 
-: linear, ( param op -- )
-    swons , ;
+: linear, ( node -- )
+    #! Add a node to the linear IR.
+    [ node-op get node-param get ] bind cons , ;
 
 : >linear ( node -- )
     #! Dataflow OPs have a linearizer word property. This
     #! quotation is executed to convert the node into linear
     #! form.
-    "linearizer" [ drop linear, ] apply-dataflow ;
+    "linearizer" [ linear, ] apply-dataflow ;
 
 : (linearize) ( dataflow -- )
     [ >linear ] each ;
@@ -59,24 +59,31 @@ SYMBOL: #jump ( tail-call )
     #! jumps and labels, and turns dataflow IR nodes into
     #! lists where the first element is an operation, and the
     #! rest is arguments.
-    [ (linearize)  f #return linear, ] make-list ;
+    [ (linearize) ] make-list ;
 
 : <label> ( -- label )
     gensym ;
 
 : label, ( label -- )
-    #label linear, ;
+    #label swons , ;
 
 : linearize-ifte ( param -- )
     #! The parameter is a list of two lists, each one a dataflow
     #! IR.
     uncons car
     <label> [
-        #branch-t linear,
+        #jump-label-t swons ,
         (linearize) ( false branch )
-        <label> dup #branch linear,
+        <label> dup #jump-label swons ,
     ] keep label, ( branch target of BRANCH-T )
     swap (linearize) ( true branch )
     label, ( branch target of false branch end ) ;
 
-#ifte [ linearize-ifte ] "linearizer" set-word-property
+#label [
+    dup [ node-label get ] bind label,
+    [ node-param get ] bind (linearize)
+] "linearizer" set-word-property
+
+#ifte [
+    [ node-param get ] bind linearize-ifte
+] "linearizer" set-word-property

library/compiler/optimizer.factor

@@ -43,39 +43,47 @@ USE: logic
 ! quotations are lifted to their call sites.
 
 : scan-literal ( node -- )
-    "scan-literal" [ 2drop ] apply-dataflow ;
+    #! If the node represents a literal push, add the literal to
+    #! the list being constructed.
+    "scan-literal" [ drop ] apply-dataflow ;
+
+: (scan-literals) ( dataflow -- )
+    [ scan-literal ] each ;
 
 : scan-literals ( dataflow -- list )
-    [ [ scan-literal ] each ] make-list ;
+    [ (scan-literals) ] make-list ;
 
 : scan-branches ( branches -- )
-    [ [ scan-literal ] each ] each ;
+    #! Collect all literals from all branches.
+    [ node-param get ] bind [ [ scan-literal ] each ] each ;
 
 : mentions-literal? ( literal list -- )
     #! Does the given list of result objects refer to this
     #! literal?
     [ dup cons? [ car over = ] [ drop f ] ifte ] some? ;
 
-: default-kill? ( literal node -- ? )
+: consumes-literal? ( literal node -- ? )
+    #! Does the dataflow node consume the literal?
     [
         node-consume-d get mentions-literal? swap
-        node-consume-r get mentions-literal? nip or not
+        node-consume-r get mentions-literal? nip or
+    ] bind ;
+
+: produces-literal? ( literal node -- ? )
+    #! Does the dataflow node produce the literal?
+    [
+        node-produce-d get mentions-literal? swap
+        node-produce-r get mentions-literal? nip or
     ] bind ;
 
 : (can-kill?) ( literal node -- ? )
     #! Return false if the literal appears as input to this
     #! node, and this node is not a stack operation.
-    dup [ node-op get ] bind dup "shuffle" word-property [
-        3drop t
-    ] [
-        "can-kill" word-property dup [
-            call
-        ] [
-            drop default-kill?
-        ] ifte
-    ] ifte ;
+    "can-kill" [ consumes-literal? not ] apply-dataflow ;
 
 : can-kill? ( literal dataflow -- ? )
+    #! Return false if the literal appears in any node in the
+    #! list.
     [ dupd (can-kill?) ] all? nip ;
 
 : kill-set ( dataflow -- list )
@@ -83,12 +91,54 @@ USE: logic
     dup scan-literals [ over can-kill? ] subset nip ;
 
 : can-kill-branches? ( literal node -- ? )
+    #! Check if the literal appears in either branch.
     [ node-param get ] bind [ dupd can-kill? ] all? nip ;
 
-#push [ , ] "scan-literal" set-word-property
+: kill-literal ( literals node -- )
+    #! Remove the literals from the node and , it if it is not a
+    #! NOP.
+    swap [
+        over 2dup consumes-literal? >r produces-literal? r> or
+    ] some?
+    [ drop ] [ , ] ifte ;
+
+: kill-literals ( literals dataflow -- )
+    #! Remove literals and construct a list.
+    [ dupd kill-literal ] each drop ;
+
+: optimize ( dataflow -- )
+    [ dup kill-set swap kill-literals ] make-list ;
+
+#push [
+    [ node-param get ] bind ,
+] "scan-literal" set-word-property
+
+#label [
+    [ node-param get ] bind (scan-literals)
+] "scan-literal" set-word-property
+
+#label [
+    [ node-param get ] bind can-kill?
+] "can-kill" set-word-property
+
 #ifte [ scan-branches ] "scan-literal" set-word-property
 #ifte [ can-kill-branches? ] "can-kill" set-word-property
 #generic [ scan-branches ] "scan-literal" set-word-property
 #generic [ can-kill-branches? ] "can-kill" set-word-property
 #2generic [ scan-branches ] "scan-literal" set-word-property
 #2generic [ can-kill-branches? ] "can-kill" set-word-property
+
+! Don't care about inputs to recursive combinator calls
+#call-label [ 2drop t ] "can-kill" set-word-property
+
+#drop [ 2drop t ] "can-kill" set-word-property
+#dup [ 2drop t ] "can-kill" set-word-property
+#swap [ 2drop t ] "can-kill" set-word-property
+#over [ 2drop t ] "can-kill" set-word-property
+#pick [ 2drop t ] "can-kill" set-word-property
+#nip [ 2drop t ] "can-kill" set-word-property
+#tuck [ 2drop t ] "can-kill" set-word-property
+#rot [ 2drop t ] "can-kill" set-word-property
+
+#>r [ 2drop t ] "can-kill" set-word-property
+#r> [ 2drop t ] "can-kill" set-word-property

library/inference/dataflow.factor

@@ -38,7 +38,10 @@ USE: vectors
 ! We build a dataflow graph for the compiler.
 SYMBOL: dataflow-graph
 
+SYMBOL: #label
+
 SYMBOL: #call ( non-tail call )
+SYMBOL: #call-label
 SYMBOL: #push ( literal )
 
 SYMBOL: #ifte
@@ -64,6 +67,7 @@ SYMBOL: node-produce-d
 SYMBOL: node-consume-r
 SYMBOL: node-produce-r
 SYMBOL: node-op
+SYMBOL: node-label
 
 ! #push nodes have this field set to the value being pushed.
 ! #call nodes have this as the word being called
@@ -110,12 +114,10 @@ SYMBOL: node-param
 : apply-dataflow ( dataflow name default -- )
     #! For the dataflow node, look up named word property,
     #! if its not defined, apply default quotation to
-    #! ( param op ) otherwise apply property quotation to
-    #! ( param ).
-    >r >r [ node-param get  node-op get ] bind dup r>
-    word-property dup [
-        ( param op property )
-        nip call r> drop
+    #! ( node ) otherwise apply property quotation to
+    #! ( node ).
+    >r >r dup [ node-op get ] bind r> word-property dup [
+        call r> drop
     ] [
         drop r> call
     ] ifte ;

library/inference/inference.factor

@@ -54,6 +54,10 @@ SYMBOL: recursive-state
 ! ... with keys:
 SYMBOL: base-case
 SYMBOL: entry-effect
+! When a call to a combinator is compiled, recursion cannot
+! simply jump to the definition of the combinator. Instead, it
+! makes a local jump to this label.
+SYMBOL: recursive-label
 
 : gensym-vector ( n --  vector )
     dup <vector> swap [ gensym over vector-push ] times ;
@@ -98,11 +102,6 @@ SYMBOL: entry-effect
     recursive-state set
     dataflow-graph off ;
 
-: with-recursive-state ( word quot -- )
-    over <recursive-state> cons recursive-state cons@
-    call
-    recursive-state uncons@ drop ;
-
 DEFER: apply-word
 
 : apply-literal ( obj -- )

library/inference/stack.factor

@@ -38,19 +38,14 @@ USE: namespaces
     [ 0 1 node-outputs ] bind
 ] "infer" set-word-property
 
-\ >r t "shuffle" set-word-property
-
 \ r> [
     f #r> dataflow, [ 0 1 node-inputs ] extend
     pop-r push-d
     [ 1 0 node-outputs ] bind
 ] "infer" set-word-property
 
-\ r> t "shuffle" set-word-property
-
 : meta-infer ( word op -- )
     #! Mark a word as being partially evaluated.
-    dup t "shuffle" set-word-property
     dupd [
         over unit , \ car ,
         f , ,

library/inference/words.factor

@@ -49,10 +49,13 @@ USE: prettyprint
     [ pick swap dataflow-inputs ] keep
     pick 2slip swap dataflow-outputs ; inline
 
+: (consume/produce) ( param op effect -- )
+    [ unswons consume-d produce-d ] with-dataflow ;
+
 : consume/produce ( word [ in | out ] -- )
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
-    #call swap [ unswons consume-d produce-d ] with-dataflow ;
+    #call swap (consume/produce) ;
 
 : apply-effect ( word [ in | out ] -- )
     #! If a word does not have special inference behavior, we
@@ -68,10 +71,33 @@ USE: prettyprint
 : no-effect ( word -- )
     "Unknown stack effect: " swap word-name cat2 throw ;
 
+: with-recursive-state ( word label quot -- )
+    >r
+    <recursive-state> [ recursive-label set ] extend dupd cons
+    recursive-state cons@
+    r> call
+    ( recursive-state uncons@ drop ) ;
+
+: (with-block) ( label quot -- )
+    #! Call a quotation in a new namespace, and transfer
+    #! inference state from the outer scope.
+    swap >r [
+        dataflow-graph off
+        call
+        d-in get meta-d get meta-r get get-dataflow
+    ] with-scope
+    r> swap #label dataflow, [ node-label set ] bind
+    meta-r set meta-d set d-in set ;
+
+: with-block ( word label quot -- )
+    #! Execute a quotation with the word on the stack, and add
+    #! its dataflow contribution to a new block node in the IR.
+    over [ with-recursive-state ] (with-block) ;
+
 : inline-compound ( word -- effect )
     #! Infer the stack effect of a compound word in the current
     #! inferencer instance.
-    [ word-parameter infer-quot effect ] with-recursive-state ;
+    gensym [ word-parameter infer-quot effect ] with-block ;
 
 : (infer-compound) ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer
@@ -118,9 +144,15 @@ USE: prettyprint
 
 : recursive-word ( word state -- )
     #! Handle a recursive call, by either applying a previously
-    #! inferred base case, or raising an error.
-    base-case swap hash dup [
-        consume/produce
+    #! inferred base case, or raising an error. If the recursive
+    #! call is to a local block, emit a label call node.
+    base-case over hash dup [
+        swap [ recursive-label get ] bind ( word effect label )
+        dup [
+            rot drop #call-label rot
+        ] [
+            drop #call swap
+        ] ifte (consume/produce)
     ] [
         drop no-base-case
     ] ifte ;
@@ -147,13 +179,11 @@ USE: prettyprint
     ] ifte ;
 
 : infer-call ( [ rstate | quot ] -- )
-    \ drop #call dataflow, drop
-    [
-        dataflow-graph off
-        pop-d uncons recursive-state set infer-quot
-        d-in get meta-d get get-dataflow
-    ] with-scope
-    [ dataflow-graph cons@ ] each meta-d set d-in set ;
+    1 ensure-d
+    dataflow-drop,
+    gensym dup [
+        drop pop-d uncons recursive-state set infer-quot
+    ] with-block ;
 
 \ call [ infer-call ] "infer" set-word-property
 

library/test/dataflow.factor

@@ -71,14 +71,14 @@ SYMBOL: #test
     {{
         [ node-op | #test ]
         [ node-param | 5 ]
-    }} "foobar" [ drop succ ] apply-dataflow
+    }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
 ] unit-test
 
-#test [ sq ] "foobar" set-word-property
+#test [ [ node-param get ] bind sq ] "foobar" set-word-property
 
 [ 25 ] [
     {{
         [ node-op | #test ]
         [ node-param | 5 ]
-    }} "foobar" [ drop succ ] apply-dataflow
+    }} "foobar" [ [ node-param get ] bind succ ] apply-dataflow
 ] unit-test