Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/threads/threads.factor

@@ -4,3 +4,4 @@ IN: bootstrap.threads
 
 USE: io.thread
 USE: threads
+USE: debugger.threads

basis/concurrency/mailboxes/mailboxes.factor

@@ -4,7 +4,7 @@ IN: concurrency.mailboxes
 USING: dlists dequeues threads sequences continuations
 destructors namespaces random math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
-debugger ;
+debugger debugger.threads ;
 
 TUPLE: mailbox threads data disposed ;
 

basis/debugger/debugger.factor

@@ -5,10 +5,10 @@ kernel math namespaces prettyprint prettyprint.config sequences
 assocs sequences.private strings io.styles io.files vectors
 words system splitting math.parser classes.tuple continuations
 continuations.private combinators generic.math classes.builtin
-classes compiler.units generic.standard vocabs threads
+classes compiler.units generic.standard vocabs init
-threads.private init kernel.private libc io.encodings accessors
+kernel.private io.encodings accessors math.order
-math.order destructors source-files parser classes.tuple.parser
+destructors source-files parser classes.tuple.parser
-effects.parser lexer compiler.errors dlists generic.parser
+effects.parser lexer compiler.errors generic.parser
 strings.parser ;
 IN: debugger
 
@@ -245,33 +245,6 @@ M: no-compilation-unit error.
 M: no-vocab summary
     drop "Vocabulary does not exist" ;
 
-M: bad-ptr summary
-    drop "Memory allocation failed" ;
-
-M: double-free summary
-    drop "Free failed since memory is not allocated" ;
-
-M: realloc-error summary
-    drop "Memory reallocation failed" ;
-
-: error-in-thread. ( thread -- )
-    "Error in thread " write
-    [
-        dup thread-id #
-        " (" % dup thread-name %
-        ", " % dup thread-quot unparse-short % ")" %
-    ] "" make swap write-object ":" print nl ;
-
-! Hooks
-M: thread error-in-thread ( error thread -- )
-    initial-thread get-global eq? [
-        die drop
-    ] [
-        global [
-            error-thread get-global error-in-thread. print-error flush
-        ] bind
-    ] if ;
-
 M: encode-error summary drop "Character encoding error" ;
 
 M: decode-error summary drop "Character decoding error" ;
@@ -348,9 +321,6 @@ M: object compiler-error. ( error word -- )
     nl
     print-error ;
 
-M: empty-dlist summary ( dlist -- )
-    drop "Empty dlist" ;
-
 M: bad-effect summary
     drop "Bad stack effect declaration" ;
 

basis/debugger/threads/threads.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors debugger continuations threads threads.private
+io io.styles prettyprint kernel math.parser namespaces ;
+IN: debugger.threads
+
+: error-in-thread. ( thread -- )
+    "Error in thread " write
+    [
+        dup id>> #
+        " (" % dup name>> %
+        ", " % dup quot>> unparse-short % ")" %
+    ] "" make swap write-object ":" print nl ;
+
+M: thread error-in-thread ( error thread -- )
+    initial-thread get-global eq? [
+        die drop
+    ] [
+        global [
+            error-thread get-global error-in-thread. print-error flush
+        ] bind
+    ] if ;

basis/dlists/dlists.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences accessors dequeues ;
+USING: combinators kernel math sequences accessors dequeues
+summary ;
 IN: dlists
 
 TUPLE: dlist front back length ;
@@ -80,6 +81,9 @@ M: dlist push-back* ( obj dlist -- dlist-node )
 
 ERROR: empty-dlist ;
 
+M: empty-dlist summary ( dlist -- )
+    drop "Empty dlist" ;
+
 M: dlist peek-front ( dlist -- obj )
     front>> [ obj>> ] [ empty-dlist ] if* ;
 

basis/libc/libc.factor

@@ -3,7 +3,7 @@
 ! Copyright (C) 2007, 2008 Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien assocs continuations destructors kernel
-namespaces accessors sets ;
+namespaces accessors sets summary ;
 IN: libc
 
 <PRIVATE
@@ -34,13 +34,22 @@ PRIVATE>
 
 ERROR: bad-ptr ;
 
+M: bad-ptr summary
+    drop "Memory allocation failed" ;
+
 : check-ptr ( c-ptr -- c-ptr )
     [ bad-ptr ] unless* ;
 
 ERROR: double-free ;
 
+M: double-free summary
+    drop "Free failed since memory is not allocated" ;
+
 ERROR: realloc-error ptr size ;
 
+M: realloc-error summary
+    drop "Memory reallocation failed" ;
+
 <PRIVATE
 
 : add-malloc ( alien -- )

basis/tools/deploy/deploy-tests.factor

@@ -26,7 +26,7 @@ namespaces continuations layouts accessors ;
 
 [ t ] [ 1300000 small-enough? ] unit-test
 
-[ "staging.math-compiler-ui-strip.image" ] [
+[ "staging.threads-math-compiler-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
@@ -79,7 +79,7 @@ M: quit-responder call-responder*
     [
         <dispatcher>
             add-quot-responder
-            "resource:basis/http/test" <static> >>default
+            "resource:extra/http/test" <static> >>default
         main-responder set
 
         test-httpd

basis/tools/deploy/shaker/shaker.factor

@@ -16,8 +16,6 @@ QUALIFIED: init
 QUALIFIED: io.backend
 QUALIFIED: io.thread
 QUALIFIED: layouts
-QUALIFIED: libc.private
-QUALIFIED: libc.private
 QUALIFIED: listener
 QUALIFIED: prettyprint.config
 QUALIFIED: source-files
@@ -178,13 +176,14 @@ IN: tools.deploy.shaker
             listener:error-hook
             init:init-hooks
             io.thread:io-thread
-            libc.private:mallocs
             source-files:source-files
             input-stream
             output-stream
             error-stream
         } %
 
+        "mallocs" "libc.private" lookup ,
+
         deploy-threads? [
             "initial-thread" "threads" lookup ,
         ] unless

core/generic/generic.factor

@@ -39,7 +39,7 @@ GENERIC: effective-method ( generic -- method )
     order [ class<= ] with filter reverse dup length 1 =
     [ drop f ] [ second ] if ;
 
-: next-method ( class generic -- class/f )
+: next-method ( class generic -- method/f )
     [ next-method-class ] keep method ;
 
 GENERIC: next-method-quot* ( class generic combination -- quot )

extra/automata/ui/ui.factor

@@ -30,7 +30,7 @@ IN: automata.ui
 
 : draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
 
-: display ( -- ) black gl-color bitmap> draw-bitmap ;
+: display ( -- ) black set-color bitmap> draw-bitmap ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/boolean-expr/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/boolean-expr/boolean-expr.factor

@@ -0,0 +1,95 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes kernel sequences sets
+io prettyprint multi-methods symbols ;
+IN: boolean-expr
+
+! Demonstrates the use of Unicode symbols in source files, and
+! multi-method dispatch.
+
+TUPLE: ⋀ x y ;
+TUPLE: ⋁ x y ;
+TUPLE: ¬ x ;
+
+SINGLETONS: ⊤ ⊥ ;
+
+SINGLETONS: P Q R S T U V W X Y Z ;
+
+UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
+
+GENERIC: ⋀ ( x y -- expr )
+
+METHOD: ⋀ { ⊤ □ } nip ;
+METHOD: ⋀ { □ ⊤ } drop ;
+METHOD: ⋀ { ⊥ □ } drop ;
+METHOD: ⋀ { □ ⊥ } nip ;
+
+METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
+METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
+
+METHOD: ⋀ { □ □ } \ ⋀ boa ;
+
+GENERIC: ⋁ ( x y -- expr )
+
+METHOD: ⋁ { ⊤ □ } drop ;
+METHOD: ⋁ { □ ⊤ } nip ;
+METHOD: ⋁ { ⊥ □ } nip ;
+METHOD: ⋁ { □ ⊥ } drop ;
+
+METHOD: ⋁ { □ □ } \ ⋁ boa ;
+
+GENERIC: ¬ ( x -- expr )
+
+METHOD: ¬ { ⊤ } drop ⊥ ;
+METHOD: ¬ { ⊥ } drop ⊤ ;
+
+METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
+METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
+
+METHOD: ¬ { □ } \ ¬ boa ;
+
+: → ( x y -- expr ) ¬ ⋀ ;
+: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
+: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
+
+GENERIC: (cnf) ( expr -- cnf )
+
+METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
+METHOD: (cnf) { □ } 1array ;
+
+GENERIC: cnf ( expr -- cnf )
+
+METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
+METHOD: cnf { □ } (cnf) 1array ;
+
+GENERIC: satisfiable? ( expr -- ? )
+
+METHOD: satisfiable? { ⊤ } drop t ;
+METHOD: satisfiable? { ⊥ } drop f ;
+
+: partition ( seq quot -- left right )
+    [ [ not ] compose filter ] [ filter ] 2bi ; inline
+
+: (satisfiable?) ( seq -- ? )
+    [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
+
+METHOD: satisfiable? { □ }
+    cnf [ (satisfiable?) ] contains? ;
+
+GENERIC: (expr.) ( expr -- )
+
+METHOD: (expr.) { □ } pprint ;
+
+: op. ( expr -- )
+    "(" write
+    [ x>> (expr.) ]
+    [ bl class pprint bl ]
+    [ y>> (expr.) ]
+    tri
+    ")" write ;
+
+METHOD: (expr.) { ⋀ } op. ;
+METHOD: (expr.) { ⋁ } op. ;
+METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
+
+: expr. ( expr -- ) (expr.) nl ;

extra/boolean-expr/summary.txt

@@ -0,0 +1 @@
+Simple boolean expression evaluator and simplifier

extra/boolean-expr/tags.txt

@@ -0,0 +1 @@
+demos

extra/golden-section/golden-section.factor

@@ -2,7 +2,7 @@
 USING: kernel namespaces math math.constants math.functions math.order
        arrays sequences
        opengl opengl.gl opengl.glu ui ui.render ui.gadgets ui.gadgets.theme
-       ui.gadgets.slate colors accessors combinators.cleave
+       ui.gadgets.cartesian colors accessors combinators.cleave
        processing.shapes ;
 
 IN: golden-section
@@ -39,20 +39,17 @@ IN: golden-section
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: display ( -- )
-  GL_PROJECTION glMatrixMode
-  glLoadIdentity
-  -400 400 -400 400 -1 1 glOrtho
-  GL_MODELVIEW glMatrixMode
-  glLoadIdentity
-  golden-section ;
-
 : golden-section-window ( -- )
     [
-      [ display ] <slate>
+      <cartesian>
         {  600 600 }       >>pdim
+        { -400 400 }       x-range
+        { -400 400 }       y-range
+        [ golden-section ] >>action
       "Golden Section" open-window
     ]
   with-ui ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 MAIN: golden-section-window

extra/processing/shapes/shapes.factor

@@ -52,6 +52,10 @@ T{ rgba f 1 1 1 1 } fill-color   set-global
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: line-strip ( seq -- ) stroke-mode GL_LINE_STRIP [ gl-vertices-2d ] do-state ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
 : triangles ( seq -- )
   [ fill-mode   GL_TRIANGLES [ gl-vertices-2d ] do-state ]
   [ stroke-mode GL_TRIANGLES [ gl-vertices-2d ] do-state ] bi ;

extra/ui/gadgets/cartesian/cartesian.factor

@@ -1,5 +1,5 @@
 
-USING: kernel combinators opengl.gl
+USING: kernel combinators sequences opengl.gl
        ui.render ui.gadgets ui.gadgets.slate
        accessors ;
 
@@ -7,15 +7,6 @@ IN: ui.gadgets.cartesian
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: init-slate ( slate -- slate )
-  init-gadget
-  [ ]         >>action
-  { 200 200 } >>pdim
-  [ ]         >>graft
-  [ ]         >>ungraft ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
 TUPLE: cartesian < slate x-min x-max y-min y-max z-min z-max perspective ;
 
 : init-cartesian ( cartesian -- cartesian )
@@ -48,3 +39,9 @@ M: cartesian draw-gadget* ( cartesian -- )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+: x-range ( cartesian range -- cartesian ) first2 [ >>x-min ] [ >>x-max ] bi* ;
+: y-range ( cartesian range -- cartesian ) first2 [ >>y-min ] [ >>y-max ] bi* ;
+: z-range ( cartesian range -- cartesian ) first2 [ >>z-min ] [ >>z-max ] bi* ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/ui/gadgets/plot/plot.factor

@@ -0,0 +1,62 @@
+
+USING: kernel quotations arrays sequences math math.ranges fry
+       opengl opengl.gl ui.render ui.gadgets.cartesian processing.shapes
+       accessors ;
+
+IN: ui.gadgets.plot
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: plot < cartesian functions points ;
+
+: init-plot ( plot -- plot )
+  init-cartesian
+    { } >>functions
+    100 >>points ;
+
+: <plot> ( -- plot ) plot new init-plot ;
+
+: step-size ( plot -- step-size )
+  [ [ x-max>> ] [ x-min>> ] bi - ] [ points>> ] bi / ;
+
+: plot-range ( plot -- range )
+  [ x-min>> ] [ x-max>> ] [ step-size ] tri <range> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: function function color ;
+
+GENERIC: plot-function ( plot object -- plot )
+
+M: quotation plot-function ( plot quotation -- plot )
+  >r dup plot-range r> '[ dup @ 2array ] map line-strip ;
+
+M: function plot-function ( plot function -- plot )
+   dup color>> dup [ >stroke-color ] [ drop ] if
+   >r dup plot-range r> function>> '[ dup @ 2array ] map line-strip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: plot-functions ( plot -- plot ) dup functions>> [ plot-function ] each ;
+
+: draw-axis ( plot -- plot )
+  dup
+    [ [ x-min>> ] [ drop 0  ] bi 2array ]
+    [ [ x-max>> ] [ drop 0  ] bi 2array ] bi line*
+  dup
+    [ [ drop 0  ] [ y-min>> ] bi 2array ]
+    [ [ drop 0  ] [ y-max>> ] bi 2array ] bi line* ;
+
+M: plot draw-gadget* ( plot -- )
+   dup call-next-method
+   2 glLineWidth
+   draw-axis
+   plot-functions
+   drop
+   fill-mode
+   1 glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: add-function ( plot function -- plot )
+  over functions>> swap suffix >>functions ;

extra/ui/gadgets/slate/slate.factor

@@ -5,13 +5,20 @@ IN: ui.gadgets.slate
 
 TUPLE: slate < gadget action pdim graft ungraft ;
 
-: <slate> ( action -- slate )
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  slate new-gadget
+
-    swap        >>action
+: init-slate ( slate -- slate )
-    { 100 100 } >>pdim
+  init-gadget
+  [ ]         >>action
+  { 200 200 } >>pdim
   [ ]         >>graft
   [ ]         >>ungraft ;
 
+: <slate> ( action -- slate )
+  slate new
+    init-slate
+    swap >>action ;
+
 M: slate pref-dim* ( slate -- dim ) pdim>> ;
 
 M: slate draw-gadget* ( slate -- ) origin get swap action>> with-translation ;

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 } }
+{ $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." }
+{ $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
+        [ >vector meta-d set ] [ f infer-quot ] bi*
-        f infer-quot
+    ] with-tree-builder nip
-    ] with-tree-builder nip ;
+    unclip-last in-d>> ;
-
-: build-tree ( quot -- nodes ) f build-tree-with ;
 
 : (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 )
+: amend-copy-equiv ( node -- )
-    <disjoint-set> copies set
+    [
-    dup [
         [ 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/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
+    [ label>> V{ } clone >>calls ]
-    >>introductions drop ;
+    [ 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
+M: #if live-branches
-    [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
+    in-d>> first value-info class>> {
-    [ t swap memq? [ first ] [ drop f ] if ]
+        { [ dup null class<= ] [ { f f } ] }
-    [ f swap memq? [ second ] [ drop f ] if ]
+        { [ dup true-class? ] [ { t f } ] }
-    2bi 2array ;
+        { [ dup false-class? ] [ { f t } ] }
+        [ { t t } ]
+    } cond nip ;
 
-M: #dispatch live-children
+M: #dispatch live-branches
-    [ children>> ] [ in-d>> first value-info interval>> ] bi
+    [ children>> length ] [ in-d>> first value-info interval>> ] bi
-    '[ , interval-contains? [ drop f ] unless ] map-index ;
+    '[ , 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 ]
+    {
+        [ annotate-phi-inputs ]
         [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
         [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
-    tri ;
+        [ 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@
+    [ slots>> ] bi@ {
+        { [ dup not ] [ drop ] }
+        { [ over not ] [ nip ] }
+        [
             2dup [ length ] bi@ =
-    [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
+            [ [ 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 '[
-        dup '[ , fold-comparison ] +outputs+ set-word-prop
+        [ , 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
+        3 { 2 1 } mixed-mutable-immutable boa [ x>> ] [ y>> ] bi
-        [ 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
+        H{ } clone value-infos set
-        (propagate)
+        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
+USING: fry accessors kernel sequences sequences.private assocs words
-words namespaces classes.algebra combinators classes
+namespaces classes.algebra combinators classes classes.tuple
-classes.tuple classes.tuple.private continuations arrays
+classes.tuple.private continuations arrays byte-arrays strings
-byte-arrays strings math math.private slots
+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 -- )
+: compute-constraints ( #call word -- )
-    dup word>> +constraints+ word-prop [ custom-constraints ] [
+    dup +constraints+ word-prop [ nip custom-constraints ] [
-        dup word>> predicate? [
+        dup predicate? [
-            [ in-d>> first ]
+            [ [ in-d>> first ] [ out-d>> first ] bi ]
-            [ word>> "predicating" word-prop ]
+            [ "predicating" word-prop ] bi*
-            [ out-d>> first ]
+            swap predicate-constraints assume
-            tri predicate-constraints assume
+        ] [ 2drop ] if
-        ] [ drop ] if
     ] if* ;
 
-: call-outputs-quot ( node -- infos )
+: call-outputs-quot ( #call word -- infos )
-    [ in-d>> [ value-info ] map ]
+    [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
-    [ word>> +outputs+ word-prop ]
+    with-datastack ;
-    bi with-datastack ;
 
-: foldable-word? ( #call -- ? )
+: foldable-call? ( #call word -- ? )
-    dup word>> "foldable" word-prop [
+    "foldable" word-prop
-        drop t
+    [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
-    ] [
-        dup word>> \ <tuple-boa> eq? [
-            in-d>> peek value-info literal>> immutable-tuple-class?
-        ] [
-            drop f
-        ] if
-    ] if ;
 
-: foldable-call? ( #call -- ? )
+: fold-call ( #call word -- infos )
-    dup word>> "foldable" word-prop [
-        in-d>> [ value-info literal?>> ] all?
-    ] [
-        drop f
-    ] if ;
-
-: fold-call ( #call -- infos )
     [ in-d>> [ value-info literal>> ] map ]
-    [ word>> [ execute ] curry ]
+    [ [ execute ] curry ]
-    bi with-datastack
+    bi* with-datastack
     [ <literal-info> ] map ;
 
-: default-output-value-infos ( node -- infos )
+: default-output-value-infos ( #call word -- infos )
-    dup word>> "default-output-classes" word-prop [
+    "default-output-classes" word-prop
-        class-infos
+    [ class-infos ] [ out-d>> length object <class-info> <repetition> ] ?if ;
-    ] [
-        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 +outputs+ word-prop ] [ call-outputs-quot ] }
-        { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
         [ default-output-value-infos ]
     } cond ;
 
-M: #call propagate-before
+: do-inlining ( #call word -- ? )
-    [ [ 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
     {
-        { [ dup reader? ] [ reader-word-inputs ] }
+        { [ dup standard-generic? ] [ inline-standard-method ] }
-        { [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
-        [ drop ]
+        { [ 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 )
+: propagate-input-classes ( node input-classes -- )
-    [ dup value-info ] H{ } map>assoc ;
+    class-infos swap in-d>> refine-value-infos ;
 
-: annotate-node ( node -- )
+M: #call propagate-after
-    dup
+    dup word>> "input-classes" word-prop dup
-    [ node-defs-values ] [ node-uses-values ] bi append
+    [ propagate-input-classes ] [ 2drop ] if ;
-    extract-value-info
-    >>info drop ;
-
-M: node propagate-around
-    [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

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 -- ? )
+: sequence-constructor? ( word -- ? )
-    word>> { <array> <byte-array> <string> } memq? ;
+    { <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 )
+: propagate-sequence-constructor ( #call word -- infos )
-    [ word>> constructor-output-class <class-info> ]
     [ in-d>> first <sequence-info> ]
-    bi value-info-intersect 1array ;
+    [ constructor-output-class <class-info> ]
+    bi* value-info-intersect 1array ;
 
-: length-accessor? ( node -- ? )
+: tuple-constructor? ( word -- ? )
-    dup in-d>> first value-info class>> fixed-length-sequence class<=
+    { <tuple-boa> <complex> } memq? ;
-    [ 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? ;
 
 : 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 )
+: propagate-tuple-constructor ( #call word -- infos )
-    dup word>> {
+    {
         { \ <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' )
+: 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? ] [
-            tuple>array* nth <literal-info>
+                [ 1- ] [ tuple>array* ] bi* nth <literal-info>
             ] }
             { [ dup complex? ] [
-            [ real-part ] [ imaginary-part ] bi
+                [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
                 2array nth <literal-info>
             ] }
-    } cond ;
+        } 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 ;
+    } cond [ object <class-info> ] unless* ;
-
-: 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 ;

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

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
+    inline-recursive new swap >>word ;
-        swap >>word
-        V{ } clone >>calls ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;