Propagation now does method inlining; working on cleanup pass

unfinished/compiler/tree/builder/builder-docs.factor

@@ -23,14 +23,14 @@ $nl
 { $subsection specialized-def } ;
 
 HELP: build-tree
-{ $values { "quot" quotation } { "dataflow" node } }
+{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
 { $description "Attempts to construct tree SSA IR from a quotation." }
 { $notes "This is the first stage of the compiler." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 HELP: build-tree-with
-{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
-{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
+{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
+{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values, and outputting stack resulting at the end." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 HELP: specialized-def

unfinished/compiler/tree/builder/builder.factor

@@ -11,16 +11,16 @@ IN: compiler.tree.builder
     [ V{ } clone stack-visitor set ] prepose
     with-infer ; inline
 
-GENERIC# build-tree-with 1 ( quot stack -- nodes )
+: build-tree ( quot -- nodes )
+    #! Not safe to call from inference transforms.
+    [ f infer-quot ] with-tree-builder nip ;
 
-M: callable build-tree-with
+: build-tree-with ( in-stack quot -- nodes out-stack )
     #! Not safe to call from inference transforms.
     [
-        >vector meta-d set
-        f infer-quot
-    ] with-tree-builder nip ;
-
-: build-tree ( quot -- nodes ) f build-tree-with ;
+        [ >vector meta-d set ] [ f infer-quot ] bi*
+    ] with-tree-builder nip
+    unclip-last in-d>> ;
 
 : (make-specializer) ( class picker -- quot )
     swap "predicate" word-prop append ;

unfinished/compiler/tree/cleanup/cleanup-tests.factor

@@ -0,0 +1,578 @@
+IN: compiler.tree.cleanup.tests
+USING: tools.test kernel.private kernel arrays sequences
+math.private math generic words quotations alien alien.c-types
+strings sbufs sequences.private slots.private combinators
+definitions system layouts vectors math.partial-dispatch
+math.order math.functions accessors hashtables classes assocs
+io.encodings.utf8 io.encodings.ascii io.encodings fry
+compiler.tree
+compiler.tree.combinators
+compiler.tree.cleanup
+compiler.tree.builder
+compiler.tree.copy-equiv
+compiler.tree.normalization
+compiler.tree.propagation ;
+
+: cleaned-up-tree ( quot -- nodes )
+    build-tree normalize compute-copy-equiv propagate cleanup ;
+
+[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
+
+[ f ] [ [ f [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
+
+[ f ] [ [ { array } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
+
+[ t ] [ [ { sequence } declare [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
+
+: recursive-test ( a -- b ) dup [ not recursive-test ] when ; inline recursive
+
+[ t ] [ [ recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
+
+[ f ] [ [ f recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
+
+[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
+
+: inlined? ( quot seq/word -- ? )
+    [ cleaned-up-tree ] dip
+    dup word? [ 1array ] when
+    '[ dup #call? [ word>> , member? ] [ drop f ] if ]
+    contains-node? not ;
+
+[ f ] [
+    [ { integer } declare >fixnum ]
+    \ >fixnum inlined?
+] unit-test
+
+GENERIC: mynot ( x -- y )
+
+M: f mynot drop t ;
+
+M: object mynot drop f ;
+
+GENERIC: detect-f ( x -- y )
+
+M: f detect-f ;
+
+[ t ] [
+    [ dup [ mynot ] [ ] if detect-f ] \ detect-f inlined?
+] unit-test
+
+GENERIC: xyz ( n -- n )
+
+M: integer xyz ;
+
+M: object xyz ;
+
+[ t ] [
+    [ { integer } declare xyz ] \ xyz inlined?
+] unit-test
+
+[ t ] [
+    [ dup fixnum? [ xyz ] [ drop "hi" ] if ]
+    \ xyz inlined?
+] unit-test
+
+: (fx-repeat) ( i n quot: ( i -- i ) -- )
+    2over fixnum>= [
+        3drop
+    ] [
+        [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat)
+    ] if ; inline recursive
+
+: fx-repeat ( n quot -- )
+    0 -rot (fx-repeat) ; inline
+
+! The + should be optimized into fixnum+, if it was not, then
+! the type of the loop index was not inferred correctly
+[ t ] [
+    [ [ dup 2 + drop ] fx-repeat ] \ + inlined?
+] unit-test
+
+: (i-repeat) ( i n quot: ( i -- i ) -- )
+    2over dup xyz drop >= [
+        3drop
+    ] [
+        [ swap >r call 1+ r> ] keep (i-repeat)
+    ] if ; inline recursive
+
+: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline
+
+[ t ] [
+    [ [ dup xyz drop ] i-repeat ] \ xyz inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare dup 100 >= [ 1 + ] unless ] \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
+    \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare dupd < [ 1 + 1 + ] when ]
+    \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ ] times ] \ >= inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ ] times ] \ 1+ inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ ] times ] \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ ] times ] \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+    [ { integer fixnum } declare dupd < [ 1 + ] when ]
+    \ + inlined?
+] unit-test
+
+[ f ] [
+    [ { integer fixnum } declare dupd < [ 1 + ] when ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
+
+[ f ] [
+    [
+        [ no-cond ] 1
+        [ 1array dup quotation? [ >quotation ] unless ] times
+    ] \ quotation? inlined?
+] unit-test
+
+[ t ] [
+    [
+        1000000000000000000000000000000000 [ ] times
+    ] \ + inlined?
+] unit-test
+[ f ] [
+    [
+        1000000000000000000000000000000000 [ ] times
+    ] \ +-integer-fixnum inlined?
+] unit-test
+
+[ f ] [
+    [ { bignum } declare [ ] times ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+    [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+] unit-test
+
+[ t ] [
+    [ { array-capacity } declare 0 < ] \ < inlined?
+] unit-test
+
+[ t ] [
+    [ { array-capacity } declare 0 < ] \ fixnum< inlined?
+] unit-test
+
+[ t ] [
+    [ { array-capacity } declare 1 fixnum- ] \ fixnum- inlined?
+] unit-test
+
+[ t ] [
+    [ 5000 [ 5000 [ ] times ] times ] \ 1+ inlined?
+] unit-test
+
+[ t ] [
+    [ 5000 [ [ ] times ] each ] \ 1+ inlined?
+] unit-test
+
+[ t ] [
+    [ 5000 0 [ dup 2 - swap [ 2drop ] curry each ] reduce ]
+    \ 1+ inlined?
+] unit-test
+
+GENERIC: annotate-entry-test-1 ( x -- )
+
+M: fixnum annotate-entry-test-1 drop ;
+
+: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
+    2over >= [
+        3drop
+    ] [
+        [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
+    ] if ; inline recursive
+
+: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
+
+[ f ] [
+    [ { bignum } declare [ ] annotate-entry-test-2 ]
+    \ annotate-entry-test-1 inlined?
+] unit-test
+
+[ t ] [
+    [ { float } declare 10 [ 2.3 * ] times >float ]
+    \ >float inlined?
+] unit-test
+
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
+[ t ] [
+    [ { real float } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
+[ t ] [
+    [ { float real } declare + detect-float ]
+    \ detect-float inlined?
+] unit-test
+
+[ t ] [
+    [ 3 + = ] \ equal? inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum } declare 7 bitand neg shift ]
+    \ fixnum-shift-fast inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 7 bitand neg shift ]
+    { shift fixnum-shift } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+    { shift fixnum-shift } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+    { fixnum-shift-fast } inlined?
+] unit-test
+
+cell-bits 32 = [
+    [ t ] [
+        [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+        \ shift inlined?
+    ] unit-test
+
+    [ f ] [
+        [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+        \ fixnum-shift inlined?
+    ] unit-test
+] when
+
+[ f ] [
+    [ { integer } declare -63 shift 4095 bitand ]
+    \ shift inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short 0 number= ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short 0 { number number } declare number= ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short 0 = ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ B{ 1 0 } *short dup number? [ 0 number= ] [ drop f ] if ]
+    \ number= inlined?
+] unit-test
+
+[ t ] [
+    [ HEX: ff bitand 0 HEX: ff between? ]
+    \ >= inlined?
+] unit-test
+
+[ t ] [
+    [ HEX: ff swap HEX: ff bitand >= ]
+    \ >= inlined?
+] unit-test
+
+[ t ] [
+    [ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
+] unit-test
+
+[ t ] [
+    [
+        dup integer? [
+            dup fixnum? [
+                1 +
+            ] [
+                2 +
+            ] if
+        ] when
+    ] \ + inlined?
+] unit-test
+
+[ f ] [
+    [
+        256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+    [
+        dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare dup 0 >= [ 256 mod ] when
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 256 rem
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 rem ] map
+    ] { mod fixnum-mod rem } inlined?
+] unit-test
+
+[ t ] [
+    [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+] unit-test
+
+: rec ( a -- b )
+    dup 0 > [ 1 - rec ] when ; inline recursive
+
+[ t ] [
+    [ { fixnum } declare rec 1 + ]
+    { > - + } inlined?
+] unit-test
+
+: fib ( m -- n )
+    dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline recursive
+
+[ t ] [
+    [ 27.0 fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27.0 fib ] { +-integer-integer } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 fib ] { < - + } inlined?
+] unit-test
+
+[ t ] [
+    [ 27 >bignum fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+    [ 27/2 fib ] { < - } inlined?
+] unit-test
+
+: hang-regression ( m n -- x )
+    over 0 number= [
+        nip
+    ] [
+        dup [
+            drop 1 hang-regression
+        ] [
+            dupd hang-regression hang-regression
+        ] if
+    ] if ; inline recursive
+
+[ t ] [
+    [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
+] { } inlined? ] unit-test
+
+[ t ] [
+    [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
+    \ fixnum-bitand inlined?
+] unit-test
+
+[ t ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+    [ { integer } declare 127 bitand 3 + ]
+    { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare length [ drop ] each-integer ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare [ drop ] each ]
+    { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    { < <-integer-fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum } declare 0 [ + ] reduce ]
+    \ +-integer-fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare
+        dup 0 >= [
+            615949 * 797807 + 20 2^ mod dup 19 2^ -
+        ] [ dup ] if
+    ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare
+        615949 * 797807 + 20 2^ mod dup 19 2^ -
+    ] { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare [ ] map
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+    [
+        { integer } declare 1 + { } set-nth-unsafe
+    ] \ >fixnum inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { fixnum } declare 0 swap
+        [
+            drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+        ] map
+    ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ hashtable new ] \ new inlined?
+] unit-test
+
+[ t ] [
+    [ dup hashtable eq? [ new ] when ] \ new inlined?
+] unit-test
+
+[ t ] [
+    [ { hashtable } declare hashtable instance? ] \ instance? inlined?
+] unit-test
+
+[ t ] [
+    [ { vector } declare hashtable instance? ] \ instance? inlined?
+] unit-test
+
+[ f ] [
+    [ { assoc } declare hashtable instance? ] \ instance? inlined?
+] unit-test
+
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+    [ { declared-fixnum } declare [ 1 + ] change-x ]
+    { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+    [ { declared-fixnum } declare x>> drop ]
+    { slot } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { array } declare length
+        1 + dup 100 fixnum> [ 1 fixnum+ ] when
+    ] \ fixnum+ inlined?
+] unit-test
+ 
+[ t ] [
+    [ [ resize-array ] keep length ] \ length inlined?
+] unit-test
+
+[ t ] [
+    [ dup 0 > [ sqrt ] when ] \ sqrt inlined?
+] unit-test
+
+[ t ] [
+    [ { utf8 } declare decode-char ] \ decode-char inlined?
+] unit-test
+
+[ t ] [
+    [ { ascii } declare decode-char ] \ decode-char inlined?
+] unit-test
+
+[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 256 mod ] map
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+    [
+        { integer } declare [ 0 >= ] map
+    ] { >= fixnum>= } inlined?
+] unit-test

unfinished/compiler/tree/cleanup/cleanup.factor

@@ -1,5 +1,106 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sequences.deep combinators fry
+namespaces
+compiler.tree
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.tree.propagation.branches ;
 IN: compiler.tree.cleanup
 
-: cleanup ( nodes -- nodes' ) ;
+! A phase run after propagation to finish the job, so to speak.
+! Codifies speculative inlining decisions, deletes branches
+! marked as never taken, and flattens local recursive blocks
+! that do not call themselves.
+
+GENERIC: cleanup* ( node -- node/nodes )
+
+: cleanup ( nodes -- nodes' )
+    #! We don't recurse into children here, instead the methods
+    #! do it since the logic is a bit more involved
+    [ cleanup* ] map flatten ;
+
+: cleanup-constant-folding ( #call -- nodes )
+    [
+        [ node-output-infos ] [ out-d>> ] bi
+        [ [ literal>> ] dip #push ] 2map
+    ]
+    [ in-d>> #drop ] bi prefix ;
+
+: cleanup-inlining ( #call -- nodes )
+    body>> cleanup ;
+
+M: #call cleanup*
+    {
+        { [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
+        { [ dup body>> ] [ cleanup-inlining ] }
+        [ ]
+    } cond ;
+
+GENERIC: delete-node ( node -- )
+
+M: #call-recursive delete-node
+    dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+
+M: #return-recursive delete-node
+    label>> f >>return drop ;
+
+M: node delete-node drop ;
+
+: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
+
+: delete-unreachable-branches ( #branch -- )
+    dup live-branches>> '[
+        ,
+        [ [ [ drop ] [ delete-nodes ] if ] 2each ]
+        [ select-children ]
+        2bi
+    ] change-children drop ;
+
+: fold-only-branch ( #branch -- node/nodes )
+    #! If only one branch is live we don't need to branch at
+    #! all; just drop the condition value.
+    dup live-children sift dup length 1 =
+    [ first swap in-d>> #drop prefix ] [ drop ] if ;
+
+SYMBOL: live-branches
+
+: cleanup-children ( #branch -- )
+    [ [ cleanup ] map ] change-children drop ;
+
+M: #branch cleanup*
+    {
+        [ live-branches>> live-branches set ]
+        [ delete-unreachable-branches ]
+        [ cleanup-children ]
+        [ fold-only-branch ]
+    } cleave ;
+
+: cleanup-phi-in ( phi-in live-branches -- phi-in' )
+    swap dup empty?
+    [ nip ] [ flip swap select-children sift flip ] if ;
+
+M: #phi cleanup*
+    #! Remove #phi function inputs which no longer exist.
+    live-branches get {
+        [ '[ , cleanup-phi-in ] change-phi-in-d ]
+        [ '[ , cleanup-phi-in ] change-phi-in-r ]
+        [ '[ , cleanup-phi-in ] change-phi-info-d ]
+        [ '[ , cleanup-phi-in ] change-phi-info-r ]
+    } cleave ;
+
+: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
+
+: flatten-recursive ( #recursive -- nodes )
+    #! convert #enter-recursive and #return-recursive into
+    #! #copy nodes.
+    child>>
+    unclip >copy prefix
+    unclip-last >copy suffix ;
+
+M: #recursive cleanup*
+    #! Inline bodies of #recursive blocks with no calls left.
+    [ cleanup ] change-child
+    dup label>> calls>> empty? [ flatten-recursive ] when ;
+
+M: node cleanup* ;

unfinished/compiler/tree/combinators/combinators-tests.factor

@@ -3,3 +3,4 @@ USING: compiler.tree.combinators tools.test kernel ;
 
 { 1 0 } [ [ drop ] each-node ] must-infer-as
 { 1 1 } [ [ ] map-nodes ] must-infer-as
+{ 1 1 } [ [ ] contains-node? ] must-infer-as

unfinished/compiler/tree/combinators/combinators.factor

@@ -4,7 +4,7 @@ USING: fry kernel accessors sequences sequences.deep
 compiler.tree ;
 IN: compiler.tree.combinators
 
-: each-node ( nodes quot -- )
+: each-node ( nodes quot: ( node -- ) -- )
     dup dup '[
         , [
             dup #branch? [
@@ -15,7 +15,7 @@ IN: compiler.tree.combinators
                 ] [ drop ] if
             ] if
         ] bi
-    ] each ; inline
+    ] each ; inline recursive
 
 : map-nodes ( nodes quot: ( node -- node' ) -- nodes )
     dup dup '[
@@ -28,3 +28,19 @@ IN: compiler.tree.combinators
             ] when
         ] if
     ] map flatten ; inline recursive
+
+: contains-node? ( nodes quot: ( node -- ? ) -- ? )
+    dup dup '[
+        , keep swap [ drop t ] [
+            dup #branch? [
+                children>> [ , contains-node? ] contains?
+            ] [
+                dup #recursive? [
+                    child>> , contains-node?
+                ] [ drop f ] if
+            ] if
+        ] if
+    ] contains? ; inline recursive
+
+: select-children ( seq flags -- seq' )
+    [ [ drop f ] unless ] 2map ;

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -5,6 +5,9 @@ kernel accessors fry
 compiler.tree compiler.tree.def-use compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
+! Two values are copy-equivalent if they are always identical
+! at run-time ("DS" relation).
+
 ! Disjoint set of copy equivalence
 SYMBOL: copies
 
@@ -49,10 +52,13 @@ M: #phi compute-copy-equiv*
 
 M: node compute-copy-equiv* drop ;
 
-: compute-copy-equiv ( node -- node )
-    <disjoint-set> copies set
-    dup [
+: amend-copy-equiv ( node -- )
+    [
         [ node-defs-values [ introduce-value ] each ]
         [ compute-copy-equiv* ]
         bi
     ] each-node ;
+
+: compute-copy-equiv ( node -- node )
+    <disjoint-set> copies set
+    dup amend-copy-equiv ;

unfinished/compiler/tree/loop/detection/detection.factor

@@ -0,0 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop-detection
+
+: detect-loops ( nodes -- nodes' ) ;

unfinished/compiler/tree/normalization/normalization.factor

@@ -51,13 +51,16 @@ M: node count-introductions* drop ;
 ! Collect label info
 GENERIC: collect-label-info ( node -- )
 
-M: #return-recursive collect-label-info dup label>> (>>return) ;
+M: #return-recursive collect-label-info
+    dup label>> (>>return) ;
 
-M: #call-recursive collect-label-info dup label>> calls>> push ;
+M: #call-recursive collect-label-info
+    dup label>> calls>> push ;
 
 M: #recursive collect-label-info
-    [ label>> ] [ child>> count-introductions ] bi
-    >>introductions drop ;
+    [ label>> V{ } clone >>calls ]
+    [ child>> count-introductions ]
+    bi >>introductions drop ;
 
 M: node collect-label-info drop ;
 

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -4,6 +4,7 @@ USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators
 compiler.tree
 compiler.tree.def-use
+compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -19,17 +20,22 @@ M: #if child-constraints
 M: #dispatch child-constraints
     children>> length f <repetition> ;
 
-GENERIC: live-children ( #branch -- children )
+GENERIC: live-branches ( #branch -- indices )
 
-M: #if live-children
-    [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
-    [ t swap memq? [ first ] [ drop f ] if ]
-    [ f swap memq? [ second ] [ drop f ] if ]
-    2bi 2array ;
+M: #if live-branches
+    in-d>> first value-info class>> {
+        { [ dup null class<= ] [ { f f } ] }
+        { [ dup true-class? ] [ { t f } ] }
+        { [ dup false-class? ] [ { f t } ] }
+        [ { t t } ]
+    } cond nip ;
 
-M: #dispatch live-children
-    [ children>> ] [ in-d>> first value-info interval>> ] bi
-    '[ , interval-contains? [ drop f ] unless ] map-index ;
+M: #dispatch live-branches
+    [ children>> length ] [ in-d>> first value-info interval>> ] bi
+    '[ , interval-contains? ] map ;
+
+: live-children ( #branch -- children )
+    [ children>> ] [ live-branches>> ] bi select-children ;
 
 SYMBOL: infer-children-data
 
@@ -56,22 +62,27 @@ SYMBOL: infer-children-data
     infer-children-data get
     '[ , [ [ value-info ] bind ] 2map ] map ;
 
-: annotate-phi-node ( #phi -- )
+: annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d
     dup phi-in-r>> compute-phi-input-infos >>phi-info-r
-    dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info
     drop ;
 
+: annotate-phi-outputs ( #phi -- )
+    dup [ out-d>> ] [ out-r>> ] bi append extract-value-info
+    >>info drop ;
+
 : merge-value-infos ( infos outputs -- )
     [ [ value-infos-union ] map ] dip set-value-infos ;
 
 SYMBOL: condition-value
 
 M: #phi propagate-before ( #phi -- )
-    [ annotate-phi-node ]
-    [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
-    [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
-    tri ;
+    {
+        [ annotate-phi-inputs ]
+        [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
+        [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
+        [ annotate-phi-outputs ]
+    } cleave ;
 
 : branch-phi-constraints ( output values booleans -- )
      {
@@ -115,6 +126,7 @@ M: #phi propagate-around ( #phi -- )
     [ propagate-before ] [ propagate-after ] bi ;
 
 M: #branch propagate-around
+    dup live-branches >>live-branches
     [ infer-children ] [ annotate-node ] bi ;
 
 M: #if propagate-around

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -107,6 +107,3 @@ M: sequence assume* [ assume ] each ;
 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
 
 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
-
-: save-constraints ( quot -- )
-    constraints get clone slip constraints set ; inline

unfinished/compiler/tree/propagation/info/info-tests.factor

@@ -1,5 +1,5 @@
 USING: accessors math math.intervals sequences classes.algebra
-math kernel tools.test compiler.tree.propagation.info ;
+math kernel tools.test compiler.tree.propagation.info arrays ;
 IN: compiler.tree.propagation.info.tests
 
 [ f ] [ 0.0 -0.0 eql? ] unit-test
@@ -63,3 +63,11 @@ IN: compiler.tree.propagation.info.tests
 ] unit-test
 
 [ ] [ { } value-infos-union drop ] unit-test
+
+TUPLE: test-tuple { x read-only } ;
+
+[ t ] [
+    f f 3 <literal-info> 3array test-tuple <tuple-info> dup
+    object <class-info>
+    value-info-intersect =
+] unit-test

unfinished/compiler/tree/propagation/info/info.factor

@@ -132,9 +132,14 @@ DEFER: (value-info-intersect)
     } cond ;
 
 : intersect-slots ( info1 info2 -- slots )
-    [ slots>> ] bi@
-    2dup [ length ] bi@ =
-    [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
+    [ slots>> ] bi@ {
+        { [ dup not ] [ drop ] }
+        { [ over not ] [ nip ] }
+        [
+            2dup [ length ] bi@ =
+            [ [ intersect-slot ] 2map ] [ 2drop f ] if
+        ]
+    } cond ;
 
 : (value-info-intersect) ( info1 info2 -- info )
     [ <value-info> ] 2dip

unfinished/compiler/tree/propagation/inlining/inlining.factor

@@ -1,3 +1,144 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel arrays sequences math math.order
+math.partial-dispatch generic generic.standard classes.algebra
+classes.union sets quotations assocs combinators words
+namespaces
+compiler.tree
+compiler.tree.builder
+compiler.tree.copy-equiv
+compiler.tree.normalization
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes ;
 IN: compiler.tree.propagation.inlining
+
+! Splicing nodes
+GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
+
+M: word splicing-nodes
+    [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
+
+M: quotation splicing-nodes
+    [ [ out-d>> ] [ in-d>> ] bi ] dip
+    build-tree-with
+    rot #copy suffix
+    normalize ;
+
+: propagate-body ( #call -- )
+    body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
+
+! Dispatch elimination
+: eliminate-dispatch ( #call word/quot/f -- ? )
+    [
+        over method>> over = [ drop ] [
+            2dup splicing-nodes
+            [ >>method ] [ >>body ] bi*
+        ] if
+        propagate-body t
+    ] [ f >>method f >>body drop f ] if* ;
+
+: inlining-standard-method ( #call word -- method/f )
+    [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
+    [ swap nth value-info class>> ] dip
+    specific-method ;
+
+: inline-standard-method ( #call word -- ? )
+    dupd inlining-standard-method eliminate-dispatch ;
+
+: normalize-math-class ( class -- class' )
+    {
+        null
+        fixnum bignum integer
+        ratio rational
+        float real
+        complex number
+        object
+    } [ class<= ] with find nip ;
+
+: inlining-math-method ( #call word -- quot/f )
+    swap in-d>>
+    first2 [ value-info class>> normalize-math-class ] bi@
+    3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
+
+: inline-math-method ( #call word -- ? )
+    dupd inlining-math-method eliminate-dispatch ;
+
+: inlining-math-partial ( #call word -- quot/f )
+    [ "derived-from" word-prop first inlining-math-method ]
+    [ nip 1quotation ] 2bi
+    [ = not ] [ drop ] 2bi and ;
+
+: inline-math-partial ( #call word -- ? )
+    dupd inlining-math-partial eliminate-dispatch ;
+
+! Method body inlining
+SYMBOL: recursive-calls
+DEFER: (flat-length)
+
+: word-flat-length ( word -- n )
+    {
+        ! not inline
+        { [ dup inline? not ] [ drop 1 ] }
+        ! recursive and inline
+        { [ dup recursive-calls get key? ] [ drop 10 ] }
+        ! inline
+        [ [ recursive-calls get conjoin ] [ def>> (flat-length) ] bi ]
+    } cond ;
+
+: (flat-length) ( seq -- n )
+    [
+        {
+            { [ dup quotation? ] [ (flat-length) 2 + ] }
+            { [ dup array? ] [ (flat-length) ] }
+            { [ dup word? ] [ word-flat-length ] }
+            [ drop 0 ]
+        } cond
+    ] sigma ;
+
+: flat-length ( word -- n )
+    H{ } clone recursive-calls [
+        [ recursive-calls get conjoin ]
+        [ def>> (flat-length) 5 /i ]
+        bi
+    ] with-variable ;
+
+: classes-known? ( #call -- ? )
+    in-d>> [
+        value-info class>>
+        [ class-types length 1 = ]
+        [ union-class? not ]
+        bi and
+    ] contains? ;
+
+: inlining-rank ( #call word -- n )
+    [ classes-known? 2 0 ? ]
+    [
+        {
+            [ flat-length 24 swap [-] 4 /i ]
+            [ "default" word-prop -4 0 ? ]
+            [ "specializer" word-prop 1 0 ? ]
+            [ method-body? 1 0 ? ]
+        } cleave
+    ] bi* + + + + ;
+
+: should-inline? ( #call word -- ? )
+    inlining-rank 5 >= ;
+
+SYMBOL: history
+
+: remember-inlining ( word -- )
+    history get [ swap suffix ] change ;
+
+: inline-word ( #call word -- )
+    dup history get memq? [
+        2drop
+    ] [
+        [
+            dup remember-inlining
+            dupd def>> splicing-nodes >>body
+            propagate-body
+        ] with-scope
+    ] if ;
+
+: inline-method-body ( #call word -- ? )
+    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;

unfinished/compiler/tree/propagation/known-words/known-words.factor

@@ -173,8 +173,8 @@ generic-comparison-ops [
     } case ;
 
 comparison-ops [
-    [
-        dup '[ , fold-comparison ] +outputs+ set-word-prop
+    dup '[
+        [ , fold-comparison ] +outputs+ set-word-prop
     ] each-derived-op
 ] each
 

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences accessors kernel
+USING: sequences accessors kernel assocs sequences
+compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
@@ -14,4 +15,20 @@ GENERIC: propagate-after ( node -- )
 
 GENERIC: propagate-around ( node -- )
 
-: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;
+: (propagate) ( node -- ) [ propagate-around ] each ;
+
+: extract-value-info ( values -- assoc )
+    [ dup value-info ] H{ } map>assoc ;
+
+: annotate-node ( node -- )
+    dup
+    [ node-defs-values ] [ node-uses-values ] bi append
+    extract-value-info
+    >>info drop ;
+
+M: node propagate-before drop ;
+
+M: node propagate-after drop ;
+
+M: node propagate-around
+    [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -5,11 +5,10 @@ accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
 byte-arrays classes.algebra classes.tuple.private
 math.functions math.private strings layouts
-compiler.tree.propagation.info ;
+compiler.tree.propagation.info slots.private ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
-\ propagate/node must-infer
 
 : final-info ( quot -- seq )
     build-tree
@@ -52,6 +51,10 @@ IN: compiler.tree.propagation.tests
 
 [ V{ integer } ] [ [ /i ] final-classes ] unit-test
 
+[ V{ integer } ] [
+    [ { integer } declare bitnot ] final-classes
+] unit-test
+
 [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
 
 [ V{ integer } ] [
@@ -316,7 +319,7 @@ cell-bits 32 = [
 ! Array length propagation
 [ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
 
-[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
+[ V{ t } ] [ [ [ 10 f <array> length ] [ 10 <byte-array> length ] if 10 = ] final-literals ] unit-test
 
 [ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
 
@@ -325,15 +328,6 @@ TUPLE: prop-test-tuple { x integer } ;
 
 [ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test
 
-TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ;
-
-UNION: prop-test-union prop-test-tuple another-prop-test-tuple ;
-
-[ t ] [
-    [ { prop-test-union } declare x>> ] final-classes first
-    rational class=
-] unit-test
-
 TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
 
 [ V{ T{ fold-boa-test-tuple f 1 2 3 } } ]
@@ -377,6 +371,8 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
     ] final-classes
 ] unit-test
 
+[ ] [ [ dup 3 slot swap 4 slot dup 3 slot swap 4 slot ] final-info drop ] unit-test
+
 [ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test
 [ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test
 
@@ -404,8 +400,13 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 
 [ V{ integer array } ] [
     [
-        3 { 2 1 } mixed-mutable-immutable boa
-        [ x>> ] [ y>> ] bi
+        3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
+    ] final-classes
+] unit-test
+
+[ V{ array integer } ] [
+    [
+        3 { 2 1 } mixed-mutable-immutable boa [ y>> ] [ x>> ] bi
     ] final-classes
 ] unit-test
 
@@ -459,3 +460,18 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
 [ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
 
 [ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
+
+[ ] [ [ [ ] [ ] compose curry call ] final-info drop ] unit-test
+
+[ V{ } ] [
+    [ [ drop ] [ drop ] compose curry (each-integer) ] final-classes
+] unit-test
+
+GENERIC: iterate ( obj -- next-obj ? )
+M: fixnum iterate f ;
+M: array iterate first t ;
+
+: dead-loop ( obj -- final-obj )
+    iterate [ dead-loop ] when ; inline recursive
+
+[ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test

unfinished/compiler/tree/propagation/propagation.factor

@@ -12,15 +12,9 @@ compiler.tree.propagation.constraints
 compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
-: propagate-with ( node infos -- )
+: propagate ( node -- node )
     [
         H{ } clone constraints set
-        >hashtable value-infos set
-        (propagate)
+        H{ } clone value-infos set
+        dup (propagate)
     ] with-scope ;
-
-: propagate ( node -- node )
-    dup f propagate-with ;
-
-: propagate/node ( node existing -- )
-    info>> propagate-with ;

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -4,6 +4,7 @@ USING: kernel sequences accessors arrays fry math.intervals
 combinators
 stack-checker.inlining
 compiler.tree
+compiler.tree.copy-equiv
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -53,11 +54,14 @@ M: #recursive propagate-around ( #recursive -- )
     iter-counter get 10 > [ "Oops" throw ] when
     dup label>> t >>fixed-point drop [
         [
+            copies [ clone ] change
+            constraints [ clone ] change
+
             child>>
             [ first propagate-recursive-phi ]
             [ (propagate) ]
             bi
-        ] save-constraints
+        ] with-scope
     ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
 
 : generalize-return-interval ( info -- info' )

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -1,17 +1,21 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs
-words namespaces classes.algebra combinators classes
-classes.tuple classes.tuple.private continuations arrays
-byte-arrays strings math math.private slots
+USING: fry accessors kernel sequences sequences.private assocs words
+namespaces classes.algebra combinators classes classes.tuple
+classes.tuple.private continuations arrays byte-arrays strings
+math math.partial-dispatch math.private slots generic
+generic.standard generic.math
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.slots
+compiler.tree.propagation.inlining
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.simple
 
+! Propagation for straight-line code.
+
 M: #introduce propagate-before
     value>> object <class-info> swap set-value-info ;
 
@@ -40,91 +44,61 @@ M: #declare propagate-before
     [ [ in-d>> ] [ out-d>> ] bi append ] dip
     with-datastack first assume ;
 
-: compute-constraints ( #call -- )
-    dup word>> +constraints+ word-prop [ custom-constraints ] [
-        dup word>> predicate? [
-            [ in-d>> first ]
-            [ word>> "predicating" word-prop ]
-            [ out-d>> first ]
-            tri predicate-constraints assume
-        ] [ drop ] if
+: compute-constraints ( #call word -- )
+    dup +constraints+ word-prop [ nip custom-constraints ] [
+        dup predicate? [
+            [ [ in-d>> first ] [ out-d>> first ] bi ]
+            [ "predicating" word-prop ] bi*
+            swap predicate-constraints assume
+        ] [ 2drop ] if
     ] if* ;
 
-: call-outputs-quot ( node -- infos )
-    [ in-d>> [ value-info ] map ]
-    [ word>> +outputs+ word-prop ]
-    bi with-datastack ;
+: call-outputs-quot ( #call word -- infos )
+    [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
+    with-datastack ;
 
-: foldable-word? ( #call -- ? )
-    dup word>> "foldable" word-prop [
-        drop t
-    ] [
-        dup word>> \ <tuple-boa> eq? [
-            in-d>> peek value-info literal>> immutable-tuple-class?
-        ] [
-            drop f
-        ] if
-    ] if ;
+: foldable-call? ( #call word -- ? )
+    "foldable" word-prop
+    [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
 
-: foldable-call? ( #call -- ? )
-    dup word>> "foldable" word-prop [
-        in-d>> [ value-info literal?>> ] all?
-    ] [
-        drop f
-    ] if ;
-
-: fold-call ( #call -- infos )
+: fold-call ( #call word -- infos )
     [ in-d>> [ value-info literal>> ] map ]
-    [ word>> [ execute ] curry ]
-    bi with-datastack
+    [ [ execute ] curry ]
+    bi* with-datastack
     [ <literal-info> ] map ;
 
-: default-output-value-infos ( node -- infos )
-    dup word>> "default-output-classes" word-prop [
-        class-infos
-    ] [
-        out-d>> length object <class-info> <repetition>
-    ] ?if ;
+: default-output-value-infos ( #call word -- infos )
+    "default-output-classes" word-prop
+    [ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
 
-: output-value-infos ( node -- infos )
+: output-value-infos ( #call word -- infos )
     {
-        { [ dup foldable-call? ] [ fold-call ] }
+        { [ 2dup foldable-call? ] [ fold-call ] }
         { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
-        { [ dup word>> reader? ] [ reader-word-outputs ] }
         { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
-        { [ dup length-accessor? ] [ propagate-length ] }
-        { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
+        { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
         [ default-output-value-infos ]
     } cond ;
 
-M: #call propagate-before
-    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
-    [ compute-constraints ]
-    bi ;
-
-M: node propagate-before drop ;
-
-: propagate-input-classes ( node -- )
-    [ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi
-    refine-value-infos ;
-
-M: #call propagate-after
+: do-inlining ( #call word -- ? )
     {
-        { [ dup reader? ] [ reader-word-inputs ] }
-        { [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
-        [ drop ]
+        { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
+        { [ dup math-partial? ] [ inline-math-partial ] }
+        { [ dup method-body? ] [ inline-method-body ] }
+        [ 2drop f ]
     } cond ;
 
-M: node propagate-after drop ;
+M: #call propagate-before
+    dup word>> 2dup do-inlining [ 2drop ] [
+        [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
+        [ compute-constraints ]
+        2bi
+    ] if ;
 
-: extract-value-info ( values -- assoc )
-    [ dup value-info ] H{ } map>assoc ;
+: propagate-input-classes ( node input-classes -- )
+    class-infos swap in-d>> refine-value-infos ;
 
-: annotate-node ( node -- )
-    dup
-    [ node-defs-values ] [ node-uses-values ] bi append
-    extract-value-info
-    >>info drop ;
-
-M: node propagate-around
-    [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
+M: #call propagate-after
+    dup word>> "input-classes" word-prop dup
+    [ propagate-input-classes ] [ 2drop ] if ;

unfinished/compiler/tree/propagation/slots/slots.factor

@@ -3,7 +3,7 @@
 USING: fry assocs arrays byte-arrays strings accessors sequences
 kernel slots classes.algebra classes.tuple classes.tuple.private
 words math math.private combinators sequences.private namespaces
-compiler.tree.propagation.info ;
+classes compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.slots
 
 ! Propagation of immutable slots and array lengths
@@ -13,8 +13,8 @@ IN: compiler.tree.propagation.slots
 
 UNION: fixed-length-sequence array byte-array string ;
 
-: sequence-constructor? ( node -- ? )
-    word>> { <array> <byte-array> <string> } memq? ;
+: sequence-constructor? ( word -- ? )
+    { <array> <byte-array> <string> } memq? ;
 
 : constructor-output-class ( word -- class )
     {
@@ -23,21 +23,13 @@ UNION: fixed-length-sequence array byte-array string ;
         { <string> string }
     } at ;
 
-: propagate-sequence-constructor ( node -- infos )
-    [ word>> constructor-output-class <class-info> ]
+: propagate-sequence-constructor ( #call word -- infos )
     [ in-d>> first <sequence-info> ]
-    bi value-info-intersect 1array ;
+    [ constructor-output-class <class-info> ]
+    bi* value-info-intersect 1array ;
 
-: length-accessor? ( node -- ? )
-    dup in-d>> first value-info class>> fixed-length-sequence class<=
-    [ word>> \ length eq? ] [ drop f ] if ;
-
-: propagate-length ( node -- infos )
-    in-d>> first value-info length>>
-    [ array-capacity <class-info> ] unless* 1array ;
-
-: tuple-constructor? ( node -- ? )
-    word>> { <tuple-boa> <complex> } memq? ;
+: tuple-constructor? ( word -- ? )
+    { <tuple-boa> <complex> } memq? ;
 
 : read-only-slots ( values class -- slots )
     #! Delegation.
@@ -49,7 +41,7 @@ UNION: fixed-length-sequence array byte-array string ;
     [ , f , [ literal>> ] map % ] { } make >tuple
     <literal-info> ;
 
-: propagate-<tuple-boa> ( node -- info )
+: propagate-<tuple-boa> ( #call -- info )
     #! Delegation
     in-d>> [ value-info ] map unclip-last
     literal>> class>> [ read-only-slots ] keep
@@ -59,72 +51,45 @@ UNION: fixed-length-sequence array byte-array string ;
         <tuple-info>
     ] if ;
 
-: propagate-<complex> ( node -- info )
+: propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
 
-: propagate-tuple-constructor ( node -- infos )
-    dup word>> {
+: propagate-tuple-constructor ( #call word -- infos )
+    {
         { \ <tuple-boa> [ propagate-<tuple-boa> ] }
         { \ <complex> [ propagate-<complex> ] }
     } case 1array ;
 
-: relevant-methods ( node -- methods )
-    [ word>> "methods" word-prop ]
-    [ in-d>> first value-info class>> ] bi
-    '[ drop , classes-intersect? ] assoc-filter ;
-
-: relevant-slots ( node -- slots )
-    relevant-methods [ nip "reading" word-prop ] { } assoc>map ;
-
-: no-reader-methods ( input slots -- info )
-    2drop null-info ;
-
-: same-offset ( slots -- slot/f )
-    dup [ dup [ read-only>> ] when ] all? [
-        [ offset>> ] map dup all-equal? [ first ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: (reader-word-outputs) ( reader -- info )
-    null
-    [ [ class>> ] [ object ] if* class-or ] reduce
-    <class-info> ;
-
 : tuple>array* ( tuple -- array )
     prepare-tuple>array
     >r copy-tuple-slots r>
     prefix ;
 
-: literal-info-slot ( slot info -- info' )
-    {
-        { [ dup tuple? ] [
-            tuple>array* nth <literal-info>
-        ] }
-        { [ dup complex? ] [
-            [ real-part ] [ imaginary-part ] bi
-            2array nth <literal-info>
-        ] }
-    } cond ;
+: read-only-slot? ( n class -- ? )
+    all-slots [ offset>> = ] with find nip
+    dup [ read-only>> ] when ;
+
+: literal-info-slot ( slot object -- info/f )
+    2dup class read-only-slot? [
+        {
+            { [ dup tuple? ] [
+                [ 1- ] [ tuple>array* ] bi* nth <literal-info>
+            ] }
+            { [ dup complex? ] [
+                [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
+                2array nth <literal-info>
+            ] }
+        } cond
+    ] [ 2drop f ] if ;
+
+: length-accessor? ( slot info -- ? )
+    [ 1 = ] [ length>> ] bi* and ;
 
 : value-info-slot ( slot info -- info' )
     #! Delegation.
     {
         { [ over 0 = ] [ 2drop fixnum <class-info> ] }
-        { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
+        { [ 2dup length-accessor? ] [ nip length>> ] }
+        { [ dup literal?>> ] [ literal>> literal-info-slot ] }
         [ [ 1- ] [ slots>> ] bi* ?nth ]
-    } cond ;
-
-: reader-word-outputs ( node -- infos )
-    [ relevant-slots ] [ in-d>> first ] bi
-    over empty? [ no-reader-methods ] [
-        over same-offset dup
-        [ swap value-info value-info-slot ] [ 2drop f ] if
-        [ ] [ (reader-word-outputs) ] ?if
-    ] if 1array ;
-
-: reader-word-inputs ( node -- )
-    [ in-d>> first ] [
-        relevant-slots keys
-        object [ class>> [ class-and ] when* ] reduce
-        <class-info>
-    ] bi
-    refine-value-info ;
+    } cond [ object <class-info> ] unless* ;

unfinished/compiler/tree/tree.factor

@@ -16,7 +16,7 @@ TUPLE: #introduce < node value ;
 : #introduce ( value -- node )
     \ #introduce new swap >>value ;
 
-TUPLE: #call < node word history in-d out-d ;
+TUPLE: #call < node word in-d out-d body method ;
 
 : #call ( inputs outputs word -- node )
     \ #call new
@@ -70,7 +70,7 @@ TUPLE: #terminate < node in-d ;
     \ #terminate new
         swap >>in-d ;
 
-TUPLE: #branch < node in-d children ;
+TUPLE: #branch < node in-d children live-branches ;
 
 : new-branch ( value children class -- node )
     new
@@ -140,6 +140,8 @@ TUPLE: #copy < node in-d out-d ;
         swap >>out-d
         swap >>in-d ;
 
+: in/out ( node -- in-d out-d ) [ in-d>> ] [ out-d>> ] bi ; inline
+
 : node, ( node -- ) stack-visitor get push ;
 
 M: vector child-visitor V{ } clone ;

unfinished/stack-checker/branches/branches.factor

@@ -12,10 +12,13 @@ IN: stack-checker.branches
 : unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
     dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
 
+: pad-with-f ( seq -- newseq )
+    dup [ length ] map supremum '[ , f pad-left ] map ;
+
 : phi-inputs ( max-d-in pairs -- newseq )
     dup empty? [ nip ] [
         swap '[ , _ first2 unify-inputs ] map
-        dup [ length ] map supremum '[ , f pad-left ] map
+        pad-with-f
         flip
     ] if ;
 

unfinished/stack-checker/inlining/inlining.factor

@@ -20,9 +20,7 @@ IN: stack-checker.inlining
 TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
 
 : <inline-recursive> ( word -- label )
-    inline-recursive new
-        swap >>word
-        V{ } clone >>calls ;
+    inline-recursive new swap >>word ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;