Rewritten linearizer

library/alien/alien-callback.factor

@@ -62,4 +62,4 @@ M: alien-callback-error summary ( error -- )
     ] make-linear ;
 
 M: alien-callback linearize* ( node -- )
-    compile-gc dup linearize-callback linearize-next ;
+    compile-gc linearize-callback iterate-next ;

library/alien/alien-invoke.factor

@@ -73,9 +73,8 @@ M: alien-invoke linearize* ( node -- )
     compile-gc
     dup alien-invoke-parameters objects>registers
     dup alien-invoke-dlsym %alien-invoke ,
-    dup linearize-cleanup
+    dup linearize-cleanup box-return
-    dup box-return
+    iterate-next ;
-    linearize-next ;
 
 : parse-arglist ( return seq -- types stack-effect )
     unpair [

library/bootstrap/boot-stage1.factor

@@ -120,7 +120,6 @@ vectors words ;
         "/library/inference/words.factor"
         "/library/inference/class-infer.factor"
         "/library/inference/kill-literals.factor"
-        "/library/inference/split-nodes.factor"
         "/library/inference/optimizer.factor"
         "/library/inference/inline-methods.factor"
         "/library/inference/known-words.factor"

library/compiler/linearizer.factor

@@ -1,14 +1,48 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays compiler-backend hashtables inference kernel
+namespaces sequences words ;
 IN: compiler-frontend
-USING: arrays compiler-backend errors generic hashtables
-inference kernel math namespaces prettyprint sequences
-strings words ;
 
-: in-1 0 0 %peek-d , ;
+SYMBOL: node-stack
-: in-2 0 1 %peek-d ,  1 0 %peek-d , ;
+
-: in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
+: >node node-stack get push ;
-: out-1 T{ vreg f 0 } 0 %replace-d , ;
+: node> node-stack get pop ;
+: node@ node-stack get peek ;
+
+DEFER: iterate-nodes
+
+: iterate-children ( quot -- )
+    node@ node-children [ swap iterate-nodes ] each ;
+
+: iterate-next ( -- node ) node@ node-successor ;
+
+: iterate-nodes ( node quot -- )
+    over [
+        [ swap >node call node> drop ] keep
+        over [ iterate-nodes ] [ 2drop ] if
+    ] [
+        2drop
+    ] if ; inline
+
+: with-node-iterator ( quot -- )
+    [
+        V{ } clone node-stack set call
+    ] with-scope ; inline
+
+DEFER: #terminal?
+
+PREDICATE: #merge #terminal-merge node-successor #terminal? ;
+
+UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
+
+: tail-call? ( -- ? )
+    node-stack get [ node-successor ] map [ #terminal? ] all? ;
+
+GENERIC: linearize* ( node -- next )
+
+: linearize-child ( node -- )
+    [ node@ linearize* ] iterate-nodes ;
 
 ! A map from words to linear IR.
 SYMBOL: linearized
@@ -17,20 +51,14 @@ SYMBOL: linearized
 ! name in different scopes.
 SYMBOL: renamed-labels
 
-: rename-label ( label -- label )
-    <label> dup rot renamed-labels get set-hash ;
-
-: renamed-label ( label -- label )
-    renamed-labels get hash ;
-
-GENERIC: linearize* ( node -- )
-
 : make-linear ( word quot -- )
-    swap >r [ %prologue , call ] { } make r>
+    [
-    linearized get set-hash ; inline
+        swap >r [ %prologue , call ] { } make r>
+        linearized get set-hash
+    ] with-node-iterator ; inline
 
-: linearize-1 ( word dataflow -- )
+: linearize-1 ( word node -- )
-    swap [ linearize* ] make-linear ;
+    swap [ linearize-child ] make-linear ;
 
 : init-linearizer ( -- )
     H{ } clone linearized set
@@ -41,25 +69,36 @@ GENERIC: linearize* ( node -- )
     #! respective linear IR.
     init-linearizer linearize-1 linearized get ;
 
-: linearize-next node-successor linearize* ;
+M: node linearize* ( node -- next ) drop iterate-next ;
 
-M: f linearize* ( f -- ) drop ;
+: linearize-call ( label -- next )
+    tail-call? [
+        %jump , f
+    ] [
+        %call , iterate-next
+    ] if ;
 
-M: node linearize* ( node -- ) linearize-next ;
+: rename-label ( label -- label )
+    <label> dup rot renamed-labels get set-hash ;
 
-: linearize-call ( node label -- )
+: renamed-label ( label -- label )
-    over node-successor #return?
+    renamed-labels get hash ;
-    [ %jump , drop ] [ %call , linearize-next ] if ;
 
-: linearize-call-label ( node -- )
+: linearize-call-label ( label -- next )
-    dup node-param rename-label linearize-call ;
+    rename-label linearize-call ;
 
-M: #label linearize* ( node -- )
+M: #label linearize* ( node -- next )
     #! We remap the IR node's label to a new label object here,
     #! to avoid problems with two IR #label nodes having the
     #! same label in different lexical scopes.
-    dup linearize-call-label dup node-param renamed-label
+    dup node-param dup linearize-call-label >r
-    swap node-child linearize-1 ;
+    renamed-label swap node-child linearize-1
+    r> ;
+
+: in-1 0 0 %peek-d , ;
+: in-2 0 1 %peek-d ,  1 0 %peek-d , ;
+: in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
+: out-1 T{ vreg f 0 } 0 %replace-d , ;
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
 
@@ -67,47 +106,40 @@ M: #label linearize* ( node -- )
     dup node-successor #if?
     [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
 
-: linearize-if ( node label -- )
+: linearize-if ( node label -- next )
-    <label> dup >r >r >r dup node-children first2 linearize*
+    <label> dup >r >r >r node-children first2 linearize-child
-    r> r> %jump-label , %label , linearize* r> %label ,
+    r> r> %jump-label , %label , linearize-child r> %label ,
-    linearize-next ;
+    iterate-next ;
 
 M: #call linearize* ( node -- )
     dup if-intrinsic [
         >r <label> 2dup r> call
         >r node-successor r> linearize-if
     ] [
-        dup intrinsic [
+        dup intrinsic
-            dupd call linearize-next
+        [ call iterate-next ] [ node-param linearize-call ] if*
-        ] [
-            dup node-param linearize-call
-        ] if*
     ] if* ;
 
-M: #call-label linearize* ( node -- )
+M: #call-label linearize* ( node -- next )
-    dup node-param renamed-label linearize-call ;
+    node-param renamed-label linearize-call ;
 
-M: #if linearize* ( node -- )
+M: #if linearize* ( node -- next )
     in-1 -1 %inc-d , <label> dup 0 %jump-t , linearize-if ;
 
-: dispatch-head ( vtable -- label/code )
+: dispatch-head ( vtable -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    in-1
+    in-1 -1 %inc-d , 0 %dispatch ,
-    -1 %inc-d ,
-    0 %dispatch ,
     [ <label> dup %target-label ,  2array ] map ;
 
-: dispatch-body ( label/param -- )
+: dispatch-body ( label/node -- )
     <label> swap [
-        first2 %label , linearize* dup %jump-label ,
+        first2 %label , linearize-child dup %jump-label ,
     ] each %label , ;
 
-M: #dispatch linearize* ( vtable -- )
+M: #dispatch linearize* ( node -- next )
     #! The parameter is a list of nodes, each one is a branch to
     #! take in case the top of stack has that type.
-    dup node-children dispatch-head dispatch-body
+    node-children dispatch-head dispatch-body iterate-next ;
-    linearize-next ;
 
-M: #return linearize* ( node -- )
+M: #return linearize* drop %return , f ;
-    drop %return , ;

library/compiler/stack.factor

@@ -88,7 +88,5 @@ 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 stacks>vregs
+        dup stacks>vregs shuffle-height vregs>stacks
-        dup shuffle-height
+    ] with-scope iterate-next ;
-        vregs>stacks
-    ] with-scope linearize-next ;

library/inference/inline-methods.factor

@@ -54,6 +54,22 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 : method-dataflow ( node -- dataflow )
     dup will-inline swap node-in-d dataflow-with ;
 
+: post-inline ( #return/#values #call/#merge -- )
+    dup [
+        [
+            >r node-in-d r> node-out-d
+            2array unify-lengths first2
+        ] keep node-successor subst-values
+    ] [
+        2drop
+    ] if ;
+
+: subst-node ( old new -- )
+    #! The last node of 'new' becomes 'old', then values are
+    #! substituted. A subsequent optimizer phase kills the
+    #! last node of 'new' and the first node of 'old'.
+    last-node 2dup swap post-inline set-node-successor ;
+
 : inline-method ( node -- node )
     #! We set the #call node's param to f so that it gets killed
     #! later.
@@ -73,6 +89,13 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
         2drop f
     ] if ;
 
+: inline-literals ( node literals -- node )
+    #! Make #push -> #return -> successor
+    over drop-inputs [
+        >r >list [ literalize ] map dataflow [ subst-node ] keep
+        r> set-node-successor
+    ] keep ;
+
 : optimize-predicate ( #call -- node )
     dup node-param "predicating" word-prop >r
     dup dup node-in-d node-classes* first r> class<

library/inference/kill-literals.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: optimizer
 USING: arrays generic hashtables inference kernel math
-namespaces sequences ;
+namespaces sequences words ;
 
 : node-union ( node quot -- hash | quot: node -- )
     [
@@ -14,17 +14,18 @@ GENERIC: literals* ( node -- seq )
 : literals ( node -- hash )
     [ literals* ] node-union ;
 
+GENERIC: flushable-values* ( node -- seq )
+
+: flushable-values ( node -- hash )
+    [ flushable-values* ] node-union ;
+
 GENERIC: live-values* ( node -- seq )
 
 : live-values ( node -- hash )
     #! All values that are returned or passed to calls.
     [ live-values* ] node-union ;
 
-: kill-set ( node -- hash )
+: kill-node* ( values node -- )
-    #! Push a list of literals that may be killed in the IR.
-    dup live-values swap literals hash-diff ;
-
-: remove-values ( values node -- )
     2dup [ node-in-d remove-all ] keep set-node-in-d
     2dup [ node-out-d remove-all ] keep set-node-out-d
     2dup [ node-in-r remove-all ] keep set-node-in-r
@@ -32,11 +33,19 @@ GENERIC: live-values* ( node -- seq )
 
 : kill-node ( values node -- )
     over hash-empty?
-    [ 2drop ] [ [ remove-values ] each-node-with ] if ;
+    [ 2drop ] [ [ kill-node* ] each-node-with ] if ;
+
+: kill-unused-literals ( node -- )
+    \ live-values get over literals hash-diff swap kill-node ;
+
+: kill-values ( node -- )
+    dup live-values over literals hash-diff swap kill-node ;
 
 ! Generic nodes
 M: node literals* ( node -- ) drop { } ;
 
+M: node flushable-values* ( node -- ) drop { } ;
+
 M: node live-values* ( node -- ) node-values ;
 
 ! #shuffle
@@ -44,6 +53,11 @@ M: #shuffle literals* ( node -- seq )
     dup node-out-d swap node-out-r
     [ [ value? ] subset ] 2apply append ;
 
+! #call
+M: #call flushable-values* ( node -- )
+    dup node-param "flushable" word-prop
+    [ node-out-d ] [ drop { } ] if ;
+
 ! #return
 M: #return live-values* ( node -- seq )
     #! Values returned by local labels can be killed.

library/inference/optimizer.factor

@@ -1,13 +1,9 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer
 USING: compiler-backend generic hashtables inference kernel
 lists math namespaces sequences vectors ;
 
-! We use the recursive-state variable here, to track nested
-! label scopes, to prevent infinite loops when inlining
-! recursive methods.
-
 GENERIC: optimize-node* ( node -- node/t )
 
 : keep-optimizing ( node -- node ? )
@@ -30,16 +26,10 @@ DEFER: optimize-node
     ] [ r> ] if ;
 
 : optimize-1 ( dataflow -- dataflow ? )
-    recursive-state off
+    dup kill-values dup infer-classes optimize-node ;
-    dup kill-set over kill-node
-    dup infer-classes
-    optimize-node ;
-
-: optimize-loop ( dataflow -- dataflow )
-    optimize-1 [ optimize-loop ] when ;
 
 : optimize ( dataflow -- dataflow )
-    [ dup split-node optimize-loop ] with-scope ;
+    [ optimize-1 ] with-scope [ optimize ] when ;
 
 : prune-if ( node quot -- successor/t )
     over >r call [ r> node-successor ] [ r> drop t ] if ;

library/inference/split-nodes.factor

@@ -1,62 +0,0 @@
-IN: optimizer
-USING: arrays inference kernel lists sequences words ;
-
-! #if --> X
-!   |
-!   +--> Y
-!   |
-!   +--> Z
-
-! Becomes:
-
-! #if
-!   |
-!   +--> Y --> X
-!   |
-!   +--> Z --> X
-
-GENERIC: split-node* ( node -- )
-
-: split-node ( node -- ) drop ;
-!    [ dup split-node* node-successor split-node ] when* ;
-
-M: node split-node* ( node -- ) drop ;
-
-: post-inline ( #return/#values #call/#merge -- )
-    dup [
-        [
-            >r node-in-d r> node-out-d
-            2array unify-lengths first2
-        ] keep node-successor subst-values
-    ] [
-        2drop
-    ] if ;
-
-: subst-node ( old new -- )
-    #! The last node of 'new' becomes 'old', then values are
-    #! substituted. A subsequent optimizer phase kills the
-    #! last node of 'new' and the first node of 'old'.
-    [ last-node 2dup swap post-inline set-node-successor ] keep
-    split-node ;
-
-: inline-literals ( node literals -- node )
-    #! Make #push -> #return -> successor
-    over drop-inputs [
-        >r >list [ literalize ] map dataflow [ subst-node ] keep
-        r> set-node-successor
-    ] keep ;
-
-: split-branch ( node -- )
-    dup node-successor over node-children
-    [ >r clone-node r> subst-node ] each-with
-    f swap set-node-successor ;
-
-M: #if split-node* ( node -- )
-    split-branch ;
-
-M: #dispatch split-node* ( node -- )
-    split-branch ;
-
-! #label
-M: #label split-node* ( node -- )
-    node-child split-node ;

library/syntax/parse-syntax.factor

@@ -43,7 +43,7 @@ SYMBOL: t
 : \ scan-word literalize swons ; parsing
 : parsing word t "parsing" set-word-prop ; parsing
 : inline word  t "inline" set-word-prop ; parsing
-: flushable ( not implemented ) ; parsing
+: flushable word t "flushable" set-word-prop ; parsing
 : foldable word t "foldable" set-word-prop ; parsing
 : SYMBOL: CREATE dup reset-generic define-symbol ; parsing
 DEFER: PRIMITIVE: parsing