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

basis/alien/compiler/compiler.factor

@@ -1,417 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generator generator.registers generator.fixup
-hashtables kernel math namespaces sequences words
-inference.state inference.backend inference.dataflow system
-math.parser classes alien.arrays alien.c-types alien.strings
-alien.structs alien.syntax cpu.architecture alien summary
-quotations assocs kernel.private threads continuations.private
-libc combinators compiler.errors continuations layouts accessors
-init sets ;
-IN: alien.compiler
-
-TUPLE: #alien-node < node return parameters abi ;
-
-TUPLE: #alien-callback < #alien-node quot xt ;
-
-TUPLE: #alien-indirect < #alien-node ;
-
-TUPLE: #alien-invoke < #alien-node library function ;
-
-: large-struct? ( ctype -- ? )
-    dup c-struct? [
-        heap-size struct-small-enough? not
-    ] [ drop f ] if ;
-
-: alien-node-parameters* ( node -- seq )
-    dup parameters>>
-    swap return>> large-struct? [ "void*" prefix ] when ;
-
-: alien-node-return* ( node -- ctype )
-    return>> dup large-struct? [ drop "void" ] when ;
-
-: c-type-stack-align ( type -- align )
-    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
-
-: parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
-
-: parameter-sizes ( types -- total offsets )
-    #! Compute stack frame locations.
-    [
-        0 [
-            [ parameter-align drop dup , ] keep stack-size +
-        ] reduce cell align
-    ] { } make ;
-
-: return-size ( ctype -- n )
-    #! Amount of space we reserve for a return value.
-    dup large-struct? [ heap-size ] [ drop 0 ] if ;
-
-: alien-stack-frame ( node -- n )
-    alien-node-parameters* parameter-sizes drop ;
-
-: alien-invoke-frame ( node -- n )
-    #! One cell is temporary storage, temp@
-    dup return>> return-size
-    swap alien-stack-frame +
-    cell + ;
-
-: set-stack-frame ( n -- )
-    dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
-    swap set-stack-frame
-    call
-    f set-stack-frame ; inline
-
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
-    dup reg-class-variable inc
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
-    dup call-next-method
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-: reg-class-full? ( class -- ? )
-    [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
-    stack-params get
-    >r reg-size stack-params +@ r>
-    stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
-    [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
-    c-type-reg-class dup reg-class-full?
-    [ spill-param ] [ fastcall-param ] if
-    [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- )
-    cell /i "void*" c-type <repetition> % ;
-
-GENERIC: flatten-value-type ( type -- )
-
-M: object flatten-value-type , ;
-
-M: struct-type flatten-value-type ( type -- )
-    stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- )
-    stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        0 [
-            c-type
-            [ parameter-align (flatten-int-type) ] keep
-            [ stack-size cell align + ] keep
-            flatten-value-type
-        ] reduce drop
-    ] { } make ;
-
-: each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
-    { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
-    #! In quot you can call alloc-parameter
-    [ reset-freg-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
-    #! Moves values from C stack to registers (if word is
-    #! %load-param-reg) and registers to C stack (if word is
-    #! %save-param-reg).
-    >r
-    alien-node-parameters*
-    flatten-value-types
-    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
-    inline
-
-: if-void ( type true false -- )
-    pick "void" = [ drop nip call ] [ nip call ] if ; inline
-
-: alien-invoke-stack ( node extra -- )
-    over parameters>> length + dup reify-curries
-    over consume-values
-    dup return>> "void" = 0 1 ?
-    swap produce-values ;
-
-: param-prep-quot ( node -- quot )
-    parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
-
-: unbox-parameters ( offset node -- )
-    parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
-    ] reverse-each-parameter drop ;
-
-: prepare-box-struct ( node -- offset )
-    #! Return offset on C stack where to store unboxed
-    #! parameters. If the C function is returning a structure,
-    #! the first parameter is an implicit target area pointer,
-    #! so we need to use a different offset.
-    return>> dup large-struct?
-    [ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
-
-: objects>registers ( node -- )
-    #! Generate code for unboxing a list of C types, then
-    #! generate code for moving these parameters to register on
-    #! architectures where parameters are passed in registers.
-    [
-        [ prepare-box-struct ] keep
-        [ unbox-parameters ] keep
-        \ %load-param-reg move-parameters
-    ] with-param-regs ;
-
-: box-return* ( node -- )
-    return>> [ ] [ box-return ] if-void ;
-
-: callback-prep-quot ( node -- quot )
-    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: return-prep-quot ( node -- quot )
-    return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
-
-M: alien-invoke-error summary
-    drop
-    "Words calling ``alien-invoke'' must be compiled with the optimizing compiler." ;
-
-: pop-parameters ( -- seq )
-    pop-literal nip [ expand-constants ] map ;
-
-: stdcall-mangle ( symbol node -- symbol )
-    "@"
-    swap parameters>> parameter-sizes drop
-    number>string 3append ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
-    drop "Library not found" ;
-
-M: no-such-library compiler-error-type
-    drop +linkage+ ;
-
-: no-such-library ( name -- )
-    \ no-such-library boa
-    compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
-    drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
-    drop +linkage+ ;
-
-: no-such-symbol ( name -- )
-    \ no-such-symbol boa
-    compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
-    dup dll-valid? [
-        dupd [ dlsym ] curry contains?
-        [ drop ] [ no-such-symbol ] if
-    ] [
-        dll-path no-such-library drop
-    ] if ;
-
-: alien-invoke-dlsym ( node -- symbols dll )
-    dup function>> dup pick stdcall-mangle 2array
-    swap library>> library dup [ dll>> ] when
-    2dup check-dlsym ;
-
-\ alien-invoke [
-    ! Four literals
-    4 ensure-values
-    #alien-invoke new
-    ! Compile-time parameters
-    pop-parameters >>parameters
-    pop-literal nip >>function
-    pop-literal nip >>library
-    pop-literal nip >>return
-    ! Quotation which coerces parameters to required types
-    dup param-prep-quot recursive-state get infer-quot
-    ! Set ABI
-    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
-    ! Add node to IR
-    dup node,
-    ! Magic #: consume exactly the number of inputs
-    dup 0 alien-invoke-stack
-    ! Quotation which coerces return value to required type
-    return-prep-quot recursive-state get infer-quot
-] "infer" set-word-prop
-
-M: #alien-invoke generate-node
-    dup alien-invoke-frame [
-        end-basic-block
-        %prepare-alien-invoke
-        dup objects>registers
-        %prepare-var-args
-        dup alien-invoke-dlsym %alien-invoke
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
-
-M: alien-indirect-error summary
-    drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
-
-\ alien-indirect [
-    ! Three literals and function pointer
-    4 ensure-values
-    4 reify-curries
-    #alien-indirect new
-    ! Compile-time parameters
-    pop-literal nip >>abi
-    pop-parameters >>parameters
-    pop-literal nip >>return
-    ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
-    ! Add node to IR
-    dup node,
-    ! Magic #: consume the function pointer, too
-    dup 1 alien-invoke-stack
-    ! Quotation which coerces return value to required type
-    return-prep-quot recursive-state get infer-quot
-] "infer" set-word-prop
-
-M: #alien-indirect generate-node
-    dup alien-invoke-frame [
-        ! Flush registers
-        end-basic-block
-        ! Save registers for GC
-        %prepare-alien-invoke
-        ! Save alien at top of stack to temporary storage
-        %prepare-alien-indirect
-        dup objects>registers
-        %prepare-var-args
-        ! Call alien in temporary storage
-        %alien-indirect
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
-
-! Callbacks are registered in a global hashtable. If you clear
-! this hashtable, they will all be blown away by code GC, beware
-SYMBOL: callbacks
-
-[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
-
-: register-callback ( word -- ) callbacks get conjoin ;
-
-M: alien-callback-error summary
-    drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
-
-: callback-bottom ( node -- )
-    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
-    recursive-state get infer-quot ;
-
-\ alien-callback [
-    4 ensure-values
-    #alien-callback new dup node,
-    pop-literal nip >>quot
-    pop-literal nip >>abi
-    pop-parameters >>parameters
-    pop-literal nip >>return
-    gensym >>xt
-    callback-bottom
-] "infer" set-word-prop
-
-: box-parameters ( node -- )
-    alien-node-parameters* [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
-    [
-        dup \ %save-param-reg move-parameters
-        "nest_stacks" f %alien-invoke
-        box-parameters
-    ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
-    dup current-callback eq? [
-        drop
-    ] [
-        yield wait-to-return
-    ] if ;
-
-: do-callback ( quot token -- )
-    init-catchstack
-    dup 2 setenv
-    slip
-    wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
-    return>> {
-        { [ dup "void" = ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
-        [ c-type c-type-unboxer-quot ]
-    } cond ;
-
-: wrap-callback-quot ( node -- quot )
-    [
-        [ callback-prep-quot ]
-        [ quot>> ]
-        [ callback-return-quot ] tri 3append ,
-        [ callback-context new do-callback ] %
-    ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( node -- n )
-    {
-        { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( node -- )
-    #! All the extra book-keeping for %unwind is only for x86.
-    #! On other platforms its an alias for %return.
-    dup alien-node-return*
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
-
-: generate-callback ( node -- )
-    dup xt>> dup [
-        init-templates
-        %prologue-later
-        dup alien-stack-frame [
-            [ registers>objects ]
-            [ wrap-callback-quot %alien-callback ]
-            [ %callback-return ]
-            tri
-        ] with-stack-frame
-    ] with-generator ;
-
-M: #alien-callback generate-node
-    end-basic-block generate-callback iterate-next ;

basis/alien/compiler/summary.txt

@@ -1 +0,0 @@
-C library interface implementation

basis/binary-search/binary-search-docs.factor

@@ -24,20 +24,20 @@ $nl
 { find find-from find-last find-last find-last-from search } related-words
 
 HELP: sorted-index
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } { "elt" "an element, or " { $link f } } }
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
 { $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
 { $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
 
 { index index-from last-index last-index-from sorted-index } related-words
 
 HELP: sorted-member?
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
 { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link = } "." } ;
 
 { member? sorted-member? } related-words
 
 HELP: sorted-memq?
-{ $values { "elt" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
+{ $values { "obj" object } { "seq" "a sorted sequence" } { "?" "a boolean" } }
 { $description "Tests if the sorted sequence contains " { $snippet "elt" } ". Equality is tested with " { $link eq? } "." } ;
 
 { memq? sorted-memq? } related-words

basis/binary-search/binary-search.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private accessors math
-math.order combinators ;
+math.order combinators hints arrays ;
 IN: binary-search
 
 <PRIVATE
@@ -36,6 +36,8 @@ PRIVATE>
 : natural-search ( obj seq -- i elt )
     [ <=> ] with search ;
 
+HINTS: natural-search array ;
+
 : sorted-index ( obj seq -- i )
     natural-search drop ;
 

basis/bit-arrays/bit-arrays-docs.factor

@@ -60,11 +60,11 @@ HELP: set-bits
 { $side-effects "bit-array" } ;
 
 HELP: integer>bit-array
-{ $values { "integer" integer } { "bit-array" bit-array } }
+{ $values { "n" integer } { "bit-array" bit-array } }
 { $description "Outputs a freshly-allocated bit array whose elements correspond to the bits in the binary representation of the given unsigned integer value." }
 { $notes "The bits of the integer are stored in the resulting bit array in order of ascending significance, least significant bit first. This word will fail if passed a negative integer. If you want the two's-complement binary representation of a negative number, use " { $link bitnot } " to get the complement of the number first. This word works with fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;
 
 HELP: bit-array>integer
-{ $values { "bit-array" bit-array } { "integer" integer } }
+{ $values { "bit-array" bit-array } { "n" integer } }
 { $description "Outputs the unsigned integer whose binary representation corresponds to the contents of the given bit array." }
 { $notes "The bits of the integer are taken from the bit array in order of ascending significance, least significant bit first. This word is able to return fixnums or bignums of any size; it is not limited by fixnum size or machine word size." } ;

basis/bit-arrays/bit-arrays.factor

@@ -69,8 +69,7 @@ M: bit-array resize
 
 M: bit-array byte-length length 7 + -3 shift ;
 
-: ?{ ( parsed -- parsed )
+: ?{ \ } [ >bit-array ] parse-literal ; parsing
-    \ } [ >bit-array ] parse-literal ; parsing
 
 :: integer>bit-array ( n -- bit-array ) 
     n zero? [ 0 <bit-array> ] [
@@ -84,7 +83,7 @@ M: bit-array byte-length length 7 + -3 shift ;
         ]
     ] if ;
 
-: bit-array>integer ( bit-array -- int )
+: bit-array>integer ( bit-array -- n )
     0 swap underlying>> [ length ] keep [
         uchar-nth swap 8 shift bitor
     ] curry each ;

basis/bootstrap/compiler/compiler.factor

@@ -3,10 +3,11 @@
 USING: accessors compiler cpu.architecture vocabs.loader system
 sequences namespaces parser kernel kernel.private classes
 classes.private arrays hashtables vectors classes.tuple sbufs
-inference.dataflow hashtables.private sequences.private math
+hashtables.private sequences.private math classes.tuple.private
-classes.tuple.private growable namespaces.private assocs words
+growable namespaces.private assocs words command-line vocabs io
-generator command-line vocabs io io.encodings.string
+io.encodings.string prettyprint libc splitting math.parser
-prettyprint libc compiler.units math.order ;
+compiler.units math.order compiler.tree.builder
+compiler.tree.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -35,7 +36,7 @@ nl
     roll -roll declare not
 
     array? hashtable? vector?
-    tuple? sbuf? node? tombstone?
+    tuple? sbuf? tombstone?
 
     array-nth set-array-nth
 
@@ -71,15 +72,27 @@ nl
 "." write flush
 
 {
-    . lines
+    memq? split harvest sift cut cut-slice start index clone
+    set-at reverse push-all class number>string string>number
 } compile-uncompiled
 
 "." write flush
 
 {
-    malloc calloc free memcpy
+    lines prefix suffix unclip new-assoc update
+    word-prop set-word-prop 1array 2array 3array ?nth
 } compile-uncompiled
 
+"." write flush
+
+{
+    . malloc calloc free memcpy
+} compile-uncompiled
+
+{ build-tree } compile-uncompiled
+
+{ optimize-tree } compile-uncompiled
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

basis/cocoa/messages/messages.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings alien.compiler
+USING: alien alien.c-types alien.strings
-arrays assocs combinators compiler inference.transforms kernel
+arrays assocs combinators compiler kernel
 math namespaces parser prettyprint prettyprint.sections
 quotations sequences strings words cocoa.runtime io macros
-memoize debugger io.encodings.ascii effects ;
+memoize debugger io.encodings.ascii effects compiler.generator ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )

basis/columns/columns-docs.factor

@@ -4,7 +4,9 @@ IN: columns
 ARTICLE: "columns" "Column sequences"
 "A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
 { $subsection column }
-{ $subsection <column> } ;
+{ $subsection <column> }
+"A utility word:"
+{ $subsection <flipped> } ;
 
 HELP: column
 { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
@@ -23,4 +25,9 @@ HELP: <column> ( seq n -- column )
     "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
 } ;
 
+HELP: <flipped>
+{ $values { "seq" sequence } { "seq'" sequence } }
+{ $description "Outputs a new virtual sequence which presents the transpose of " { $snippet "seq" } "." }
+{ $notes "This is the virtual sequence equivalent of " { $link flip } "." } ;
+
 ABOUT: "columns"

basis/columns/columns.factor

@@ -13,3 +13,6 @@ M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
 M: column length seq>> length ;
 
 INSTANCE: column virtual-sequence
+
+: <flipped> ( seq -- seq' )
+    dup empty? [ dup first length [ <column> ] with map ] unless ;

basis/combinators/short-circuit/smart/smart.factor

@@ -1,11 +1,18 @@
 
-USING: kernel sequences math inference accessors macros
+USING: kernel sequences math stack-checker effects accessors macros
        combinators.short-circuit ;
 
 IN: combinators.short-circuit.smart
 
-MACRO: && ( quots -- quot )
+<PRIVATE
-  dup first infer [ in>> ] [ out>> ] bi - 1+ n&&-rewrite ;
 
-MACRO: || ( quots -- quot )
+: arity ( quots -- n )
-  dup first infer [ in>> ] [ out>> ] bi - 1+ n||-rewrite ;
+    first infer
+    dup terminated?>> [ "Cannot determine arity" throw ] when
+    effect-height neg 1+ ;
+
+PRIVATE>
+
+MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
+
+MACRO: || ( quots -- quot ) dup arity n||-rewrite ;

basis/command-line/command-line-docs.factor

@@ -52,9 +52,14 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
     { { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
 } ;
 
-ARTICLE: "cli" "Command line usage"
+ARTICLE: "rc-files" "Running code on startup"
 "Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
 $nl
+"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
+{ $subsection run-user-init }
+{ $subsection run-bootstrap-init } ;
+
+ARTICLE: "cli" "Command line usage"
 "Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."
 $nl
 "Switches can take one of the following three forms:"
@@ -68,9 +73,6 @@ $nl
 { $subsection "standard-cli-args" }
 "The list of command line arguments can be obtained and inspected directly:"
 { $subsection cli-args }
-"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
-{ $subsection run-user-init }
-{ $subsection run-bootstrap-init }
 "There is a way to override the default vocabulary to run on startup:"
 { $subsection main-vocab-hook } ;
 

basis/compiler/compiler-docs.factor

@@ -1,4 +1,4 @@
-USING: generator help.markup help.syntax words io parser
+USING: compiler.generator help.markup help.syntax words io parser
 assocs words.private sequences compiler.units ;
 IN: compiler
 

basis/compiler/compiler.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io inference.backend
+USING: kernel namespaces arrays sequences io debugger words fry
-inference.state generator debugger words compiler.units
+compiler.units continuations vocabs assocs dlists definitions
-continuations vocabs assocs alien.compiler dlists optimizer
+math threads graphs generic combinators deques search-deques
-definitions math compiler.errors threads graphs generic
+stack-checker stack-checker.state compiler.generator
-inference combinators dequeues search-dequeues ;
+compiler.errors compiler.tree.builder compiler.tree.optimizer ;
 IN: compiler
 
 SYMBOL: +failed+
@@ -46,22 +46,22 @@ SYMBOL: +failed+
     ] tri ;
 
 : (compile) ( word -- )
-    [
+    '[
         H{ } clone dependencies set
 
-        {
+        , {
             [ compile-begins ]
             [
-                [ word-dataflow ] [ compile-failed return ] recover
+                [ build-tree-from-word ] [ compile-failed return ] recover
-                optimize
+                optimize-tree
             ]
             [ dup generate ]
             [ compile-succeeded ]
         } cleave
-    ] curry with-return ;
+    ] with-return ;
 
-: compile-loop ( dequeue -- )
+: compile-loop ( deque -- )
-    [ (compile) yield ] slurp-dequeue ;
+    [ (compile) yield ] slurp-deque ;
 
 : decompile ( word -- )
     f 2array 1array t modify-code-heap ;

basis/compiler/generator/fixup/fixup-docs.factor

@@ -1,5 +1,5 @@
 USING: help.syntax help.markup math kernel
-words strings alien ;
+words strings alien compiler.generator ;
 IN: compiler.generator.fixup
 
 HELP: frame-required
@@ -14,3 +14,6 @@ HELP: rel-dlsym
 { $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
 { $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
 } ;
+
+HELP: literal-table
+{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;

basis/compiler/generator/generator-docs.factor

@@ -1,6 +1,6 @@
-USING: help.markup help.syntax words debugger generator.fixup
+USING: help.markup help.syntax words debugger
-generator.registers quotations kernel vectors arrays effects
+compiler.generator.fixup compiler.generator.registers quotations
-sequences ;
+kernel vectors arrays effects sequences ;
 IN: compiler.generator
 
 ARTICLE: "generator" "Compiled code generator"
@@ -31,16 +31,13 @@ HELP: compiled-stack-traces?
 { $values { "?" "a boolean" } }
 { $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
 
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
-
 HELP: begin-compiling
 { $values { "word" word } { "label" word } }
 { $description "Prepares to generate machine code for a word." } ;
 
 HELP: with-generator
-{ $values { "node" "a dataflow node" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
+{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
-{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
+{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
 
 HELP: generate-node
 { $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
@@ -48,13 +45,13 @@ HELP: generate-node
 { $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate-nodes
-{ $values { "node" "a dataflow node" } } 
+{ $values { "nodes" "a sequence of nodes" } } 
 { $description "Recursively generate machine code for a dataflow graph." }
 { $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
 
 HELP: generate
-{ $values { "word" word } { "label" word } { "node" "a dataflow node" } }
+{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
-{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
+{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
 
 HELP: define-intrinsics
 { $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }

basis/compiler/generator/generator.factor

@@ -3,8 +3,8 @@
 USING: accessors arrays assocs classes combinators
 cpu.architecture effects generic hashtables io kernel
 kernel.private layouts math math.parser namespaces prettyprint
-quotations sequences system threads words vectors sets dequeues
+quotations sequences system threads words vectors sets deques
-cursors continuations.private summary alien alien.c-types
+continuations.private summary alien alien.c-types
 alien.structs alien.strings alien.arrays libc compiler.errors
 stack-checker.inlining
 compiler.tree compiler.tree.builder compiler.tree.combinators
@@ -60,7 +60,8 @@ SYMBOL: current-label-start
 GENERIC: generate-node ( node -- next )
 
 : generate-nodes ( nodes -- )
-    [ current-node generate-node ] iterate-nodes end-basic-block ;
+    [ current-node generate-node ] iterate-nodes
+    end-basic-block ;
 
 : init-generate-nodes ( -- )
     init-templates
@@ -105,7 +106,7 @@ M: node generate-node drop iterate-next ;
     ] ?if ;
 
 ! #recursive
-: compile-recursive ( node -- )
+: compile-recursive ( node -- next )
     dup label>> id>> generate-call >r
     [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
     r> ;
@@ -113,7 +114,7 @@ M: node generate-node drop iterate-next ;
 : compiling-loop ( word -- )
     <label> dup resolve-label swap compiling-loops get set-at ;
 
-: compile-loop ( node -- )
+: compile-loop ( node -- next )
     end-basic-block
     [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
     iterate-next ;
@@ -150,6 +151,7 @@ M: #if generate-node
             %save-dispatch-xt
             %prologue-later
             [ generate-nodes ] with-node-iterator
+            %return
         ] with-generator
     ] keep ;
 
@@ -213,20 +215,17 @@ M: #dispatch generate-node
     2array 1array define-if-intrinsics ;
 
 : do-if-intrinsic ( pair -- next )
-    <label> [
+    <label> [ swap do-template skip-next ] keep generate-if ;
-        swap do-template
-        node> next dup >node
-    ] keep generate-if ;
 
 : find-intrinsic ( #call -- pair/f )
     intrinsics find-template ;
 
 : find-if-intrinsic ( #call -- pair/f )
-    node@ next #if? [
+    node@ {
-        if-intrinsics find-template
+        { [ dup length 2 < ] [ 2drop f ] }
-    ] [
+        { [ dup second #if? ] [ drop if-intrinsics find-template ] }
-        drop f
+        [ 2drop f ]
-    ] if ;
+    } cond ;
 
 M: #call generate-node
     dup node-input-infos [ class>> ] map set-operand-classes
@@ -252,13 +251,13 @@ M: #shuffle generate-node
     shuffle-effect phantom-shuffle iterate-next ;
 
 M: #>r generate-node
-    in-d>> length
+    [ in-d>> length ] [ out-r>> empty? ] bi
-    phantom->r
+    [ phantom-drop ] [ phantom->r ] if
     iterate-next ;
 
 M: #r> generate-node
-    out-d>> length
+    [ in-r>> length ] [ out-d>> empty? ] bi
-    phantom-r>
+    [ phantom-rdrop ] [ phantom-r> ] if
     iterate-next ;
 
 ! #return

basis/compiler/generator/iterator/iterator.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences cursors kernel compiler.tree ;
+USING: namespaces sequences kernel compiler.tree ;
 IN: compiler.generator.iterator
 
 SYMBOL: node-stack
@@ -8,15 +8,15 @@ SYMBOL: node-stack
 : >node ( cursor -- ) node-stack get push ;
 : node> ( -- cursor ) node-stack get pop ;
 : node@ ( -- cursor ) node-stack get peek ;
-: current-node ( -- node ) node@ value ;
+: current-node ( -- node ) node@ first ;
-
+: iterate-next ( -- cursor ) node@ rest-slice ;
-: iterate-next ( -- cursor ) node@ next ;
+: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
 
 : iterate-nodes ( cursor quot: ( -- ) -- )
-    over [
+    over empty? [
-        [ swap >node call node> drop ] keep iterate-nodes
-    ] [
         2drop
+    ] [
+        [ swap >node call node> drop ] keep iterate-nodes
     ] if ; inline recursive
 
 : with-node-iterator ( quot -- )
@@ -25,17 +25,21 @@ SYMBOL: node-stack
 DEFER: (tail-call?)
 
 : tail-phi? ( cursor -- ? )
-    [ value #phi? ] [ next (tail-call?) ] bi and ;
+    [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
 
 : (tail-call?) ( cursor -- ? )
-    [ value [ #return? ] [ #terminate? ] bi or ]
+    dup empty? [ drop t ] [
-    [ tail-phi? ]
+        [ first [ #return? ] [ #terminate? ] bi or ]
-    bi or ;
+        [ tail-phi? ]
+        bi or
+    ] if ;
 
 : tail-call? ( -- ? )
     node-stack get [
-        next
+        rest-slice
-        [ (tail-call?) ]
+        dup [
-        [ value #terminate? not ]
+            [ (tail-call?) ]
-        bi and
+            [ first #terminate? not ]
+            bi and
+        ] [ drop t ] if
     ] all? ;

basis/compiler/generator/registers/registers.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs classes classes.private classes.algebra
-combinators cpu.architecture generator.fixup hashtables kernel
+combinators hashtables kernel layouts math namespaces quotations
-layouts math namespaces quotations sequences system vectors
+sequences system vectors words effects alien byte-arrays
-words effects alien byte-arrays
+accessors sets math.order cpu.architecture
-accessors sets math.order ;
+compiler.generator.fixup ;
 IN: compiler.generator.registers
 
 SYMBOL: +input+
@@ -658,3 +658,9 @@ UNION: immediate fixnum POSTPONE: f ;
 : phantom-r> ( n -- )
     phantom-retainstack get phantom-input
     phantom-datastack get phantom-append ;
+
+: phantom-drop ( n -- )
+    phantom-datastack get phantom-input drop ;
+
+: phantom-rdrop ( n -- )
+    phantom-retainstack get phantom-input drop ;

basis/compiler/tests/alien.factor

@@ -1,9 +1,9 @@
-IN: alien.compiler.tests
+IN: compiler.tests
 USING: alien alien.c-types alien.syntax compiler kernel
-namespaces namespaces tools.test sequences inference words
+namespaces namespaces tools.test sequences stack-checker
-arrays parser quotations continuations inference.backend effects
+stack-checker.errors words arrays parser quotations
-namespaces.private io io.streams.string memory system threads
+continuations effects namespaces.private io io.streams.string
-tools.test math ;
+memory system threads tools.test math ;
 
 FUNCTION: void ffi_test_0 ;
 [ ] [ ffi_test_0 ] unit-test

basis/compiler/tests/insane.factor

@@ -1,4 +1,4 @@
 IN: compiler.tests
-USING: words kernel inference alien.strings tools.test ;
+USING: words kernel stack-checker alien.strings tools.test ;
 
 [ ] [ \ if redefined [ string>alien ] infer. ] unit-test

basis/compiler/tests/optimizer.factor

@@ -1,19 +1,11 @@
 USING: accessors arrays compiler.units generic hashtables
-inference kernel kernel.private math optimizer generator
+stack-checker kernel kernel.private math prettyprint sequences
-prettyprint sequences sbufs strings tools.test vectors words
+sbufs strings tools.test vectors words sequences.private
-sequences.private quotations optimizer.backend classes
+quotations classes classes.algebra classes.tuple.private
-classes.algebra inference.dataflow classes.tuple.private
+continuations growable namespaces hints alien.accessors
-continuations growable optimizer.inlining namespaces hints ;
+compiler.tree.builder compiler.tree.optimizer sequences.deep ;
 IN: optimizer.tests
 
-[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union*
-] unit-test
-
-[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [
-    H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
-] unit-test
-
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
@@ -86,7 +78,7 @@ TUPLE: pred-test ;
         3 2 (double-recursion)
     ] when ; inline
 
-: double-recursion 0 2 (double-recursion) ;
+: double-recursion ( -- ) 0 2 (double-recursion) ;
 
 [ ] [ double-recursion ] unit-test
 
@@ -124,12 +116,6 @@ GENERIC: void-generic ( obj -- * )
 : bar ( -- ? ) foo 4 4 = and ;
 [ f ] [ bar ] unit-test
 
-! ensure identities are working in some form
-[ t ] [
-    [ { number } declare 0 + ] dataflow optimize
-    [ #push? ] node-exists? not
-] unit-test
-
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
@@ -219,6 +205,7 @@ M: number detect-number ;
 
 ! Regression
 USE: sorting
+USE: binary-search
 USE: binary-search.private
 
 : old-binsearch ( elt quot seq -- elt quot i )
@@ -235,16 +222,6 @@ USE: binary-search.private
     [ [ - ] swap old-binsearch ] compile-call 2nip
 ] unit-test
 
-! Regression
-TUPLE: silly-tuple a b ;
-
-[ 1 2 { silly-tuple-a silly-tuple-b } ] [
-    T{ silly-tuple f 1 2 }
-    [
-        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
-    ] compile-call
-] unit-test
-
 ! Regression
 : empty-compound ;
 
@@ -253,9 +230,9 @@ TUPLE: silly-tuple a b ;
 
 [ t ] [ \ node-successor-f-bug compiled>> ] unit-test
 
-[ ] [ [ new ] dataflow optimize drop ] unit-test
+[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
-[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
+[ ] [ [ <tuple> ] build-tree optimize-tree drop ] unit-test
 
 ! Regression
 : lift-throw-tail-regression ( obj -- obj str )
@@ -285,28 +262,6 @@ TUPLE: silly-tuple a b ;
 
 [ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
 
-GENERIC: generic-inline-test ( x -- y )
-M: integer generic-inline-test ;
-
-: generic-inline-test-1 ( -- x )
-    1
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test
-    generic-inline-test ;
-
-! Inlining all of the above should only take two passes
-[ { t f } ] [
-    \ generic-inline-test-1 def>> dataflow
-    [ optimize-1 , optimize-1 , drop ] { } make
-] unit-test
-
 ! Forgot a recursive inline check
 : recursive-inline-hang ( a -- a )
     dup array? [ recursive-inline-hang ] when ;
@@ -347,7 +302,7 @@ USE: sequences.private
 : member-test ( obj -- ? ) { + - * / /i } member? ;
 
 \ member-test must-infer
-[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ ] [ \ member-test build-tree-from-word optimize-tree 2drop ] unit-test
 [ t ] [ \ + member-test ] unit-test
 [ f ] [ \ append member-test ] unit-test
 
@@ -391,3 +346,15 @@ TUPLE: some-tuple x ;
     [ ] curry some-tuple boa ;
 
 [ T{ some-tuple f [ 3 ] } ] [ 3 allot-regression ] unit-test
+
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-signed-4 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 } [ 0 alien-unsigned-4 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-8 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-8 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-signed-cell 1+ ] compile-call ] unit-test
+[ 1 ] [ B{ 0 0 0 0 0 0 0 0 } [ 0 alien-unsigned-cell 1+ ] compile-call ] unit-test
+
+: deep-find-test ( seq -- ? ) [ 5 = ] deep-find ;
+
+[ 5 ] [ { 1 2 { 3 { 4 5 } } } deep-find-test ] unit-test
+[ f ] [ { 1 2 { 3 { 4 } } } deep-find-test ] unit-test

basis/compiler/tests/redefine1.factor

@@ -1,7 +1,7 @@
-IN: compiler.tests
 USING: accessors compiler compiler.units tools.test math parser
 kernel sequences sequences.private classes.mixin generic
 definitions arrays words assocs eval ;
+IN: compiler.tests
 
 GENERIC: method-redefine-test ( a -- b )
 
@@ -31,15 +31,6 @@ M: integer method-redefine-test 3 + ;
 [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
 [ t ] [ \ there compiled>> ] unit-test
 
-! Just changing the stack effect didn't mark a word for recompilation
-DEFER: change-effect
-
-[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- b )" eval ] unit-test
-{ 1 1 } [ change-effect ] must-infer-as
-
-[ ] [ "IN: compiler.tests GENERIC: change-effect ( a -- )" eval ] unit-test
-{ 1 0 } [ change-effect ] must-infer-as
-
 : good ( -- ) ;
 : bad ( -- ) good ;
 : ugly ( -- ) bad ;

basis/compiler/tests/redefine4.factor

@@ -0,0 +1,12 @@
+IN: compiler.tests
+USING: io.streams.string kernel tools.test eval ;
+
+: declaration-test-1 ( -- a ) 3 ; flushable
+
+: declaration-test ( -- ) declaration-test-1 drop ;
+
+[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
+
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
+
+[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

basis/compiler/tests/simple.factor

@@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) (  -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
     ] unit-test
 ] times

basis/compiler/tests/templates-early.factor

@@ -1,9 +1,9 @@
 ! Testing templates machinery without compiling anything
 IN: compiler.tests
-USING: compiler generator generator.registers
+USING: compiler compiler.generator compiler.generator.registers
-generator.registers.private tools.test namespaces sequences
+compiler.generator.registers.private tools.test namespaces
-words kernel math effects definitions compiler.units accessors
+sequences words kernel math effects definitions compiler.units
-cpu.architecture ;
+accessors cpu.architecture ;
 
 : <int-vreg> ( n -- vreg ) int-regs <vreg> ;
 

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

@@ -0,0 +1,14 @@
+USING: help.markup help.syntax sequences quotations words 
+compiler.tree stack-checker.errors ;
+IN: compiler.tree.builder
+
+HELP: build-tree
+{ $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 { "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 quotation, 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." } ;

basis/compiler/tree/builder/builder-tests.factor

@@ -0,0 +1,11 @@
+IN: compiler.tree.builder.tests
+USING: compiler.tree.builder tools.test sequences kernel
+compiler.tree ;
+
+\ build-tree must-infer
+\ build-tree-with must-infer
+\ build-tree-from-word must-infer
+
+: inline-recursive ( -- ) inline-recursive ; inline recursive
+
+[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test

basis/compiler/tree/builder/builder.factor

@@ -0,0 +1,57 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors quotations kernel sequences namespaces
+assocs words arrays vectors hints combinators stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree ;
+IN: compiler.tree.builder
+
+: with-tree-builder ( quot -- nodes )
+    [ V{ } clone stack-visitor set ] prepose
+    with-infer ; inline
+
+: build-tree ( quot -- nodes )
+    #! Not safe to call from inference transforms.
+    [ f infer-quot ] with-tree-builder nip ;
+
+: build-tree-with ( in-stack quot -- nodes out-stack )
+    #! Not safe to call from inference transforms.
+    [
+        [ >vector meta-d set ] [ f infer-quot ] bi*
+    ] with-tree-builder nip
+    unclip-last in-d>> ;
+
+: build-sub-tree ( #call quot -- nodes )
+    [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
+    over ends-with-terminate?
+    [ drop swap [ f swap #push ] map append ]
+    [ rot #copy suffix ]
+    if ;
+
+: (build-tree-from-word) ( word -- )
+    dup
+    [ "inline" word-prop ]
+    [ "recursive" word-prop ] bi and [
+        1quotation f infer-quot
+    ] [
+        [ specialized-def ]
+        [ dup 2array 1array ] bi infer-quot
+    ] if ;
+
+: check-cannot-infer ( word -- )
+    dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+
+: check-no-compile ( word -- )
+    dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+
+: build-tree-from-word ( word -- effect nodes )
+    [
+        [
+            {
+                [ check-cannot-infer ]
+                [ check-no-compile ]
+                [ (build-tree-from-word) ]
+                [ finish-word ]
+            } cleave
+        ] maybe-cannot-infer
+    ] with-tree-builder ;

basis/compiler/tree/checker/checker-tests.factor

@@ -0,0 +1,4 @@
+IN: compiler.tree.checker.tests
+USING: compiler.tree.checker tools.test ;
+
+\ check-nodes must-infer

basis/compiler/tree/checker/checker.factor

@@ -0,0 +1,210 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel sets namespaces accessors assocs
+arrays combinators continuations columns math vectors
+stack-checker.branches
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.checker
+
+! Check some invariants; this can help catch compiler bugs.
+
+ERROR: check-use-error value message ;
+
+: check-use ( value uses -- )
+    [ empty? [ "No use" check-use-error ] [ drop ] if ]
+    [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+
+: check-def-use ( -- )
+    def-use get [ uses>> check-use ] assoc-each ;
+
+GENERIC: check-node* ( node -- )
+
+M: #shuffle check-node*
+    [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+    [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+    bi ;
+
+: check-lengths ( seq -- )
+    [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
+
+M: #copy check-node* inputs/outputs 2array check-lengths ;
+
+: check->r/r> ( node -- )
+    inputs/outputs dup empty? [ 2drop ] [ 2array check-lengths ] if ;
+
+M: #>r check-node* check->r/r> ;
+
+M: #r> check-node* check->r/r> ;
+
+M: #return-recursive check-node* inputs/outputs 2array check-lengths ;
+
+M: #phi check-node*
+    [ [ phi-in-d>> <flipped> ] [ out-d>> ] bi 2array check-lengths ]
+    [ phi-in-d>> check-lengths ]
+    bi ;
+
+M: #enter-recursive check-node*
+    [ [ label>> enter-out>> ] [ out-d>> ] bi assert= ]
+    [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+    [ recursive-phi-in check-lengths ]
+    tri ;
+
+M: #push check-node*
+    out-d>> length 1 = [ "Bad #push" throw ] unless ;
+
+M: node check-node* drop ;
+
+: check-values ( seq -- )
+    [ integer? ] all? [ "Bad values" throw ] unless ;
+
+ERROR: check-node-error node error ;
+
+: check-node ( node -- )
+    [
+        [ node-uses-values check-values ]
+        [ node-defs-values check-values ]
+        [ check-node* ]
+        tri
+    ] [ check-node-error ] recover ;
+
+SYMBOL: datastack
+SYMBOL: retainstack
+SYMBOL: terminated?
+
+GENERIC: check-stack-flow* ( node -- )
+
+: (check-stack-flow) ( nodes -- )
+    [ check-stack-flow* terminated? get not ] all? drop ;
+
+: init-stack-flow ( -- )
+    V{ } clone datastack set
+    V{ } clone retainstack set ;
+
+: check-stack-flow ( nodes -- )
+    [
+        init-stack-flow
+        (check-stack-flow)
+    ] with-scope ;
+
+: check-inputs ( seq var -- )
+    [ dup length ] dip [ swap cut* swap ] change
+    sequence= [ "Bad stack flow" throw ] unless ;
+
+: check-in-d ( node -- )
+    in-d>> datastack check-inputs ;
+
+: check-in-r ( node -- )
+    in-r>> retainstack check-inputs ;
+
+: check-outputs ( node var -- )
+    get push-all ;
+
+: check-out-d ( node -- )
+    out-d>> datastack check-outputs ;
+
+: check-out-r ( node -- )
+    out-r>> retainstack check-outputs ;
+
+M: #introduce check-stack-flow* check-out-d ;
+
+M: #push check-stack-flow* check-out-d ;
+
+M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ;
+
+M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ;
+
+: assert-datastack-empty ( -- )
+    datastack get empty? [ "Data stack not empty" throw ] unless ;
+
+: assert-retainstack-empty ( -- )
+    retainstack get empty? [ "Retain stack not empty" throw ] unless ;
+
+M: #return check-stack-flow*
+    check-in-d
+    assert-datastack-empty
+    terminated? get [ assert-retainstack-empty ] unless ;
+
+M: #enter-recursive check-stack-flow*
+    check-out-d ;
+
+M: #return-recursive check-stack-flow*
+    [ check-in-d ] [ check-out-d ] bi ;
+
+M: #call-recursive check-stack-flow*
+    [ check-in-d ] [ check-out-d ] bi ;
+
+: check-terminate-in-d ( #terminate -- )
+    in-d>> datastack get over length tail* sequence=
+    [ "Bad terminate data stack" throw ] unless ;
+
+: check-terminate-in-r ( #terminate -- )
+    in-r>> retainstack get over length tail* sequence=
+    [ "Bad terminate retain stack" throw ] unless ;
+
+M: #terminate check-stack-flow*
+    terminated? on
+    [ check-terminate-in-d ]
+    [ check-terminate-in-r ] bi ;
+
+SYMBOL: branch-out
+
+: check-branch ( nodes -- stack )
+    [
+        datastack [ clone ] change
+        V{ } clone retainstack set
+        (check-stack-flow)
+        terminated? get [ assert-retainstack-empty ] unless
+        terminated? get f datastack get ?
+    ] with-scope ;
+
+M: #branch check-stack-flow*
+    [ check-in-d ]
+    [ children>> [ check-branch ] map branch-out set ]
+    bi ;
+
+: check-phi-in ( #phi -- )
+    phi-in-d>> branch-out get [
+        dup [
+            over length tail* sequence= [
+                "Branch outputs don't match phi inputs"
+                throw
+            ] unless
+        ] [
+            2drop
+        ] if
+    ] 2each ;
+
+: set-phi-datastack ( #phi -- )
+    phi-in-d>> first length
+    branch-out get [ ] find nip swap head* >vector datastack set ;
+
+M: #phi check-stack-flow*
+    branch-out get [ ] contains? [
+        [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
+    ] [ drop terminated? on ] if ;
+
+M: #recursive check-stack-flow*
+    [ check-in-d ] [ child>> (check-stack-flow) ] bi ;
+
+M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
+
+M: #alien-callback check-stack-flow* drop ;
+
+M: #declare check-stack-flow* drop ;
+
+: check-nodes ( nodes -- )
+    compute-def-use
+    check-def-use
+    [ [ check-node ] each-node ]
+    [ check-stack-flow ]
+    bi ;

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

@@ -4,16 +4,18 @@ 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
+io.encodings.utf8 io.encodings.ascii io.encodings fry slots
+sorting.private
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
 compiler.tree.normalization
-compiler.tree.propagation ;
+compiler.tree.propagation
+compiler.tree.checker ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize propagate cleanup ;
+    build-tree normalize propagate cleanup dup check-nodes ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 
@@ -142,7 +144,7 @@ M: object xyz ;
 
 [ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
 
-[ f ] [
+[ t ] [
     [
         [ no-cond ] 1
         [ 1array dup quotation? [ >quotation ] unless ] times
@@ -430,3 +432,32 @@ cell-bits 32 = [
         { integer } declare [ 0 >= ] map
     ] { >= fixnum>= } inlined?
 ] unit-test
+
+[ ] [
+    [
+        4 pick array-capacity?
+        [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if
+    ] cleaned-up-tree drop
+] unit-test
+
+[ ] [
+    [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop
+] unit-test
+
+[ ] [
+    [
+        [ "X" throw ]
+        [ dupd dup -1 < [ 0 >= [ ] [ "X" throw ] if ] [ drop ] if ]
+        if
+    ] cleaned-up-tree drop
+] unit-test
+
+[ t ] [
+    [ [ 2array ] [ 0 3array ] if first ]
+    { nth-unsafe < <= > >= } inlined?
+] unit-test
+
+[ ] [
+    [ [ >r "A" throw r> ] [ "B" throw ] if ]
+    cleaned-up-tree drop
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs math math.private
+classes.algebra namespaces assocs words math math.private
-math.partial-dispatch classes.tuple classes.tuple.private
+math.partial-dispatch classes classes.tuple classes.tuple.private
+definitions stack-checker.state stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -15,6 +16,18 @@ IN: compiler.tree.cleanup
 ! marked as never taken, and flattens local recursive blocks
 ! that do not call themselves.
 
+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 ;
+
 GENERIC: cleanup* ( node -- node/nodes )
 
 : cleanup ( nodes -- nodes' )
@@ -29,14 +42,18 @@ GENERIC: cleanup* ( node -- node/nodes )
 : cleanup-folding ( #call -- nodes )
     #! Replace a #call having a known result with a #drop of its
     #! inputs followed by #push nodes for the outputs.
+    [ word>> +inlined+ depends-on ]
     [
         [ node-output-infos ] [ out-d>> ] bi
         [ [ literal>> ] dip #push ] 2map
     ]
-    [ in-d>> #drop ] bi prefix ;
+    [ in-d>> #drop ]
+    tri prefix ;
 
 : cleanup-inlining ( #call -- nodes )
-    body>> cleanup ;
+    [ dup method>> [ drop ] [ word>> +inlined+ depends-on ] if ]
+    [ body>> cleanup ]
+    bi ;
 
 ! Removing overflow checks
 : no-overflow-variant ( op -- fast-op )
@@ -54,35 +71,15 @@ GENERIC: cleanup* ( node -- node/nodes )
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
 
-: immutable-tuple-boa? ( #call -- ? )
-    dup word>> \ <tuple-boa> eq? [
-        dup in-d>> peek node-value-info
-        literal>> class>> immutable-tuple-class?
-    ] [ drop f ] if ;
-
-: immutable-tuple-boa ( #call -- #call )
-    \ <immutable-tuple-boa> >>word ;
-
 M: #call cleanup*
     {
         { [ dup body>> ] [ cleanup-inlining ] }
         { [ dup cleanup-folding? ] [ cleanup-folding ] }
         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
-        { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
         [ ]
     } cond ;
 
-GENERIC: delete-node ( node -- )
+M: #declare cleanup* drop f ;
-
-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>> '[
@@ -111,18 +108,26 @@ M: #branch cleanup*
         [ live-branches>> live-branches set ]
     } cleave ;
 
-: cleanup-phi-in ( phi-in live-branches -- phi-in' )
+: eliminate-single-phi ( #phi -- node )
-    swap dup empty?
+    [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
-    [ nip ] [ flip swap select-children sift flip ] if ;
+    [ [ drop ] [ [ f swap #push ] map ] bi* ]
+    [ #copy ]
+    if ;
+
+: eliminate-phi ( #phi -- node )
+    live-branches get sift length {
+        { 0 [ drop f ] }
+        { 1 [ eliminate-single-phi ] }
+        [ drop ]
+    } case ;
 
 M: #phi cleanup*
     #! Remove #phi function inputs which no longer exist.
-    live-branches get {
+    live-branches get
-        [ '[ , cleanup-phi-in ] change-phi-in-d ]
+    [ '[ , sift-children ] change-phi-in-d ]
-        [ '[ , cleanup-phi-in ] change-phi-in-r ]
+    [ '[ , sift-children ] change-phi-info-d ]
-        [ '[ , cleanup-phi-in ] change-phi-info-d ]
+    [ '[ , sift-children ] change-terminated ] tri
-        [ '[ , cleanup-phi-in ] change-phi-info-r ]
+    eliminate-phi
-    } cleave
     live-branches off ;
 
 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;

basis/compiler/tree/combinators/combinators.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel accessors sequences sequences.deep arrays
+USING: assocs fry kernel accessors sequences sequences.deep arrays
 stack-checker.inlining namespaces compiler.tree ;
 IN: compiler.tree.combinators
 
@@ -45,13 +45,17 @@ IN: compiler.tree.combinators
 : select-children ( seq flags -- seq' )
     [ [ drop f ] unless ] 2map ;
 
+: sift-children ( seq flags -- seq' )
+    zip [ nip ] assoc-filter keys ;
+
 : (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
 
 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
 
 : 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
 
-: until-fixed-point ( #recursive quot -- )
+: until-fixed-point ( #recursive quot: ( node -- ) -- )
     over label>> t >>fixed-point drop
     [ with-scope ] 2keep
-    over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; inline
+    over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ;
+    inline recursive

basis/compiler/tree/dead-code/branches/branches.factor

@@ -0,0 +1,64 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences namespaces kernel accessors assocs sets fry
+arrays combinators columns stack-checker.backend
+stack-checker.branches compiler.tree compiler.tree.combinators
+compiler.tree.dead-code.liveness compiler.tree.dead-code.simple
+;
+IN: compiler.tree.dead-code.branches
+
+M: #if mark-live-values* look-at-inputs ;
+
+M: #dispatch mark-live-values* look-at-inputs ;
+
+: look-at-phi ( value outputs inputs -- )
+    [ index ] dip swap dup [ <column> look-at-values ] [ 2drop ] if ;
+
+M: #phi compute-live-values*
+    #! If any of the outputs of a #phi are live, then the
+    #! corresponding inputs are live too.
+    [ out-d>> ] [ phi-in-d>> ] bi look-at-phi ;
+
+SYMBOL: if-node
+
+M: #branch remove-dead-code*
+    [ [ [ (remove-dead-code) ] map ] change-children ]
+    [ if-node set ]
+    bi ;
+
+: remove-phi-inputs ( #phi -- )
+    if-node get children>>
+    [ dup ends-with-terminate? [ drop f ] [ peek out-d>> ] if ] map
+    pad-with-bottom >>phi-in-d drop ;
+
+: live-value-indices ( values -- indices )
+    [ length ] keep live-values get
+    '[ , nth , key? ] filter ; inline
+
+: drop-indexed-values ( values indices -- node )
+    [ drop filter-live ] [ nths ] 2bi
+    [ make-values ] keep
+    [ drop ] [ zip ] 2bi
+    #shuffle ;
+
+: insert-drops ( nodes values indices -- nodes' )
+    '[
+        over ends-with-terminate?
+        [ drop ] [ , drop-indexed-values suffix ] if
+    ] 2map ;
+
+: hoist-drops ( #phi -- )
+    if-node get swap
+    [ phi-in-d>> ] [ out-d>> live-value-indices ] bi
+    '[ , , insert-drops ] change-children drop ;
+
+: remove-phi-outputs ( #phi -- )
+    [ filter-live ] change-out-d drop ;
+
+M: #phi remove-dead-code*
+    {
+        [ hoist-drops ]
+        [ remove-phi-inputs ]
+        [ remove-phi-outputs ]
+        [ ]
+    } cleave ;

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -0,0 +1,189 @@
+USING: namespaces assocs sequences compiler.tree.builder
+compiler.tree.dead-code compiler.tree.def-use compiler.tree
+compiler.tree.combinators compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing compiler.tree.debugger
+compiler.tree.normalization compiler.tree.checker tools.test
+kernel math stack-checker.state accessors combinators io
+prettyprint words sequences.deep sequences.private arrays
+classes kernel.private ;
+IN: compiler.tree.dead-code.tests
+
+\ remove-dead-code must-infer
+
+: count-live-values ( quot -- n )
+    build-tree
+    normalize
+    propagate
+    cleanup
+    escape-analysis
+    unbox-tuples
+    compute-def-use
+    remove-dead-code
+    0 swap [
+        dup
+        [ #push? ] [ #introduce? ] bi or
+        [ out-d>> length + ] [ drop ] if
+    ] each-node ;
+
+[ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
+
+[ 1 ] [ [ drop ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 drop ] count-live-values ] unit-test
+
+[ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
+
+[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+
+[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+
+[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+
+[ 2 ] [ [ 1 + ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
+
+[ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
+
+[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
+
+[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+
+[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ ] call ] count-live-values ] unit-test
+
+[ 1 ] [ [ [ 1 ] call ] count-live-values ] unit-test
+
+[ 2 ] [ [ [ 1 ] [ 2 ] compose call ] count-live-values ] unit-test
+
+[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
+
+[ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
+
+: optimize-quot ( quot -- quot' )
+    build-tree
+    normalize
+    propagate
+    cleanup
+    escape-analysis
+    unbox-tuples
+    compute-def-use
+    remove-dead-code
+    "no-check" get [ dup check-nodes ] unless nodes>quot ;
+
+[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
+
+[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test
+
+[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
+
+[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
+
+: flushable-1 ( a b -- c ) 2drop f ; flushable
+: flushable-2 ( a b -- c ) 2drop f ; flushable
+
+[ [ 2nip [ ] [ ] if ] ] [
+    [ [ flushable-1 ] [ flushable-2 ] if drop ] optimize-quot
+] unit-test
+
+: non-flushable-3 ( a b -- c ) 2drop f ;
+
+[ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [
+    [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
+] unit-test
+
+[ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
+
+[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
+
+[ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test
+
+[ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test
+
+[ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test
+
+: boo ( a b -- c ) 2drop f ;
+
+[ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test
+
+: squish ( quot -- quot' )
+    [
+        {
+            { [ dup word? ] [ dup vocabulary>> [ drop "REC" ] unless ] }
+            { [ dup wrapper? ] [ dup wrapped>> vocabulary>> [ drop "WRAP" ] unless ] }
+            [ ]
+        } cond
+    ] deep-map ;
+
+: call-recursive-dce-1 ( a -- b )
+    [ call-recursive-dce-1 drop ] [ call-recursive-dce-1 ] bi ; inline recursive
+
+[ [ "WRAP" [ dup >r "REC" drop r> "REC" ] label ] ] [
+    [ call-recursive-dce-1 ] optimize-quot squish
+] unit-test
+
+: produce-a-value ( -- a ) f ;
+
+: call-recursive-dce-2 ( a -- b )
+    drop
+    produce-a-value dup . call-recursive-dce-2 ; inline recursive
+
+[ [ "WRAP" [ produce-a-value . "REC" ] label ] ] [
+    [ f call-recursive-dce-2 drop ] optimize-quot squish
+] unit-test
+
+[ [ "WRAP" [ produce-a-value dup . drop "REC" ] label ] ] [
+    [ f call-recursive-dce-2 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-3 ( a -- )
+    call-recursive-dce-3 ; inline recursive
+
+[ [ [ drop "WRAP" [ "REC" ] label ] [ . ] if ] ] [
+    [ [ call-recursive-dce-3 ] [ . ] if ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-3 ] optimize-quot squish
+] unit-test
+
+: call-recursive-dce-4 ( a -- b )
+    call-recursive-dce-4 ; inline recursive
+
+[ [ "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-4 ] optimize-quot squish
+] unit-test
+
+[ [ drop "WRAP" [ "REC" ] label ] ] [
+    [ call-recursive-dce-4 drop ] optimize-quot squish
+] unit-test
+
+[ ] [ [ f call-recursive-dce-3 swap ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-5 ( -- ) call-recursive-dce-5 ; inline recursive
+
+[ ] [ [ call-recursive-dce-5 swap ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ 0 -rot set-nth-unsafe ] curry (each-integer) ] optimize-quot drop ] unit-test
+
+: call-recursive-dce-6 ( i quot: ( i -- ? ) -- i )
+    dup call [ drop ] [ call-recursive-dce-6 ] if ; inline recursive
+
+[ ] [ [ [ ] curry [ ] swap compose call-recursive-dce-6 ] optimize-quot drop ] unit-test
+
+[ ] [ [ [ ] rot [ . ] curry pick [ roll 2drop call ] [ 2nip call ] if ] optimize-quot drop ] unit-test
+
+[ [ drop ] ] [ [ array? drop ] optimize-quot ] unit-test
+
+[ [ drop ] ] [ [ array instance? drop ] optimize-quot ] unit-test
+
+[ [ drop ] ] [ [ { integer } declare f <array> drop ] optimize-quot ] unit-test
+
+[ [ f <array> drop ] ] [ [ f <array> drop ] optimize-quot ] unit-test
+
+: call-recursive-dce-7 ( obj -- elt ? )
+    dup 5 = [ t ] [ dup [ call-recursive-dce-7 ] [ drop f f ] if ] if ; inline recursive
+
+[ ] [ [ call-recursive-dce-7 ] optimize-quot drop ] unit-test

basis/compiler/tree/dead-code/dead-code.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.dead-code.branches
+compiler.tree.dead-code.liveness
+compiler.tree.dead-code.recursive
+compiler.tree.dead-code.simple ;
+IN: compiler.tree.dead-code
+
+: remove-dead-code ( nodes -- nodes )
+    init-dead-code
+    mark-live-values
+    compute-live-values
+    (remove-dead-code) ;
+

basis/compiler/tree/dead-code/liveness/liveness.factor

@@ -0,0 +1,51 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs deques search-deques
+kernel sequences sequences.deep words sets stack-checker.branches
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.dead-code.liveness
+
+SYMBOL: work-list
+
+SYMBOL: live-values
+
+: live-value? ( value -- ? ) live-values get at ;
+
+: look-at-value ( values -- ) work-list get push-front ;
+
+: look-at-values ( values -- ) work-list get push-all-front ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: init-dead-code ( -- )
+    <hashed-dlist> work-list set
+    H{ { +bottom+ f } } clone live-values set ;
+
+GENERIC: mark-live-values* ( node -- )
+
+: mark-live-values ( nodes -- nodes )
+    dup [ mark-live-values* ] each-node ; inline
+
+M: node mark-live-values* drop ;
+
+GENERIC: compute-live-values* ( value node -- )
+
+M: node compute-live-values* 2drop ;
+
+: iterate-live-values ( value -- )
+    dup live-values get key? [
+        drop
+    ] [
+        dup live-values get conjoin
+        dup defined-by compute-live-values*
+    ] if ;
+
+: compute-live-values ( -- )
+    work-list get [ iterate-live-values ] slurp-deque ;
+
+GENERIC: remove-dead-code* ( node -- node' )
+
+M: node remove-dead-code* ;
+
+: (remove-dead-code) ( nodes -- nodes' )
+    [ remove-dead-code* ] map flatten ;

basis/compiler/tree/dead-code/recursive/recursive.factor

@@ -0,0 +1,90 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs sequences kernel locals fry
+combinators stack-checker.backend
+compiler.tree
+compiler.tree.dead-code.branches
+compiler.tree.dead-code.liveness
+compiler.tree.dead-code.simple ;
+IN: compiler.tree.dead-code.recursive
+
+M: #enter-recursive compute-live-values*
+    #! If the output of an #enter-recursive is live, then the
+    #! corresponding inputs to the #call-recursive are live also.
+    [ out-d>> ] [ recursive-phi-in ] bi look-at-phi ;
+
+M: #return-recursive compute-live-values*
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
+
+M: #call-recursive compute-live-values*
+    #! If the output of a #call-recursive is live, then the
+    #! corresponding inputs to #return nodes are live also.
+    [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
+
+:: drop-dead-inputs ( inputs outputs -- #shuffle )
+    [let* | live-inputs [ inputs filter-live ]
+            new-live-inputs [ outputs inputs filter-corresponding make-values ] |
+        live-inputs
+        new-live-inputs
+        outputs
+        inputs
+        drop-values
+    ] ;
+
+M: #enter-recursive remove-dead-code*
+    [ filter-live ] change-out-d ;
+
+: drop-call-recursive-inputs ( node -- #shuffle )
+    dup [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs
+    [ out-d>> >>in-d drop ]
+    [ nip ]
+    2bi ;
+
+:: (drop-call-recursive-outputs) ( inputs outputs -- #shuffle )
+    [let* | new-live-outputs [ inputs outputs filter-corresponding make-values ]
+            live-outputs [ outputs filter-live ] |
+        new-live-outputs
+        live-outputs
+        live-outputs
+        new-live-outputs
+        drop-values
+    ] ;
+
+: drop-call-recursive-outputs ( node -- #shuffle )
+    dup [ label>> return>> in-d>> ] [ out-d>> ] bi
+    (drop-call-recursive-outputs)
+    [ in-d>> >>out-d drop ] keep ;
+
+M: #call-recursive remove-dead-code*
+    [ drop-call-recursive-inputs ]
+    [ ]
+    [ drop-call-recursive-outputs ]
+    tri 3array ;
+
+:: drop-recursive-inputs ( node -- shuffle )
+    [let* | shuffle [ node [ in-d>> ] [ label>> enter-out>> ] bi drop-dead-inputs ]
+            new-outputs [ shuffle out-d>> ] |
+        node new-outputs
+        [ [ label>> enter-recursive>> ] dip >>in-d drop ] [ >>in-d drop ] 2bi
+        shuffle
+    ] ;
+
+:: drop-recursive-outputs ( node -- shuffle )
+    [let* | return [ node label>> return>> ]
+            new-inputs [ return in-d>> filter-live ]
+            new-outputs [ return [ in-d>> ] [ out-d>> ] bi filter-corresponding ] |
+        return
+        [ new-inputs >>in-d new-outputs >>out-d drop ]
+        [ drop-dead-outputs ]
+        bi
+    ] ;
+
+M:: #recursive remove-dead-code* ( node -- nodes )
+    [let* | drop-inputs [ node drop-recursive-inputs ]
+            drop-outputs [ node drop-recursive-outputs ] |
+         node [ (remove-dead-code) ] change-child drop
+         node label>> [ filter-live ] change-enter-out drop
+         drop-inputs node drop-outputs 3array
+    ] ;
+
+M: #return-recursive remove-dead-code* ;

basis/compiler/tree/dead-code/simple/simple.factor

@@ -0,0 +1,138 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors words assocs sequences arrays namespaces
+fry locals definitions classes.algebra
+stack-checker.state
+stack-checker.backend
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.dead-code.liveness ;
+IN: compiler.tree.dead-code.simple
+
+: flushable? ( word -- ? )
+    [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+
+: flushable-call? ( #call -- ? )
+    dup word>> dup flushable? [
+        "input-classes" word-prop dup [
+            [ node-input-infos ] dip
+            [ [ class>> ] dip class<= ] 2all?
+        ] [ 2drop t ] if
+    ] [ 2drop f ] if ;
+
+M: #call mark-live-values*
+    dup flushable-call? [ drop ] [ look-at-inputs ] if ;
+
+M: #alien-invoke mark-live-values* look-at-inputs ;
+
+M: #alien-indirect mark-live-values* look-at-inputs ;
+
+M: #return mark-live-values* look-at-inputs ;
+
+: look-at-mapping ( value inputs outputs -- )
+    [ index ] dip over [ nth look-at-value ] [ 2drop ] if ;
+
+M: #copy compute-live-values*
+    #! If the output of a copy is live, then the corresponding
+    #! input is live also.
+    [ out-d>> ] [ in-d>> ] bi look-at-mapping ;
+
+M: #call compute-live-values* nip look-at-inputs ;
+
+M: #>r compute-live-values*
+    [ out-r>> ] [ in-d>> ] bi look-at-mapping ;
+
+M: #r> compute-live-values*
+    [ out-d>> ] [ in-r>> ] bi look-at-mapping ;
+
+M: #shuffle compute-live-values*
+    mapping>> at look-at-value ;
+
+M: #alien-invoke compute-live-values* nip look-at-inputs ;
+
+M: #alien-indirect compute-live-values* nip look-at-inputs ;
+
+: filter-mapping ( assoc -- assoc' )
+    live-values get '[ drop , key? ] assoc-filter ;
+
+: filter-corresponding ( new old -- old' )
+    #! Remove elements from 'old' if the element with the same
+    #! index in 'new' is dead.
+    zip filter-mapping values ;
+
+: filter-live ( values -- values' )
+    [ live-value? ] filter ;
+
+:: drop-values ( inputs outputs mapping-keys mapping-values -- #shuffle )
+    inputs
+    outputs
+    outputs
+    mapping-keys
+    mapping-values
+    filter-corresponding zip #shuffle ; inline
+
+:: drop-dead-values ( outputs -- #shuffle )
+    [let* | new-outputs [ outputs make-values ]
+            live-outputs [ outputs filter-live ] |
+        new-outputs
+        live-outputs
+        outputs
+        new-outputs
+        drop-values
+    ] ;
+
+: drop-dead-outputs ( node -- nodes )
+    dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
+
+M: #introduce remove-dead-code* ( #introduce -- nodes )
+    dup drop-dead-outputs 2array ;
+
+M: #>r remove-dead-code*
+    [ filter-live ] change-out-r
+    [ filter-live ] change-in-d
+    dup in-d>> empty? [ drop f ] when ;
+
+M: #r> remove-dead-code*
+    [ filter-live ] change-out-d
+    [ filter-live ] change-in-r
+    dup in-r>> empty? [ drop f ] when ;
+
+M: #push remove-dead-code*
+    dup out-d>> first live-value? [ drop f ] unless ;
+
+: dead-flushable-call? ( #call -- ? )
+    dup flushable-call? [
+        out-d>> [ live-value? not ] all?
+    ] [ drop f ] if ;
+
+: remove-flushable-call ( #call -- node )
+    [ word>> +inlined+ depends-on ]
+    [ in-d>> #drop remove-dead-code* ]
+    bi ;
+
+: some-outputs-dead? ( #call -- ? )
+    out-d>> [ live-value? not ] contains? ;
+
+M: #call remove-dead-code*
+    dup dead-flushable-call? [
+        remove-flushable-call
+    ] [
+        dup some-outputs-dead? [
+            dup drop-dead-outputs 2array
+        ] when
+    ] if ;
+
+M: #shuffle remove-dead-code*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    [ filter-mapping ] change-mapping
+    dup in-d>> empty? [ drop f ] when ;
+
+M: #copy remove-dead-code*
+    [ in-d>> ] [ out-d>> ] bi
+    2dup swap zip #shuffle
+    remove-dead-code* ;
+
+M: #terminate remove-dead-code*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-in-r ;

basis/compiler/tree/debugger/debugger.factor

@@ -3,12 +3,11 @@
 USING: kernel assocs fry match accessors namespaces effects
 sequences sequences.private quotations generic macros arrays
 prettyprint prettyprint.backend prettyprint.sections math words
-combinators io sorting
+combinators io sorting hints
 compiler.tree
 compiler.tree.builder
 compiler.tree.optimizer
-compiler.tree.combinators
+compiler.tree.combinators ;
-compiler.tree.propagation.info ;
 IN: compiler.tree.debugger
 
 ! A simple tool for turning tree IR into quotations and
@@ -46,18 +45,15 @@ MATCH-VARS: ?a ?b ?c ;
         { _ f }
     } match-choose ;
 
-TUPLE: shuffle effect ;
+TUPLE: shuffle-node { effect effect } ;
 
-M: shuffle pprint* effect>> effect>string text ;
+M: shuffle-node pprint* effect>> effect>string text ;
  
 M: #shuffle node>quot
     shuffle-effect dup pretty-shuffle
-    [ % ] [ shuffle boa , ] ?if ;
+    [ % ] [ shuffle-node boa , ] ?if ;
 
-: pushed-literals ( node -- seq )
+M: #push node>quot literal>> , ;
-    dup out-d>> [ node-value-info literal>> literalize ] with map ;
-
-M: #push node>quot pushed-literals % ;
 
 M: #call node>quot word>> , ;
 
@@ -78,9 +74,21 @@ M: #if node>quot
 M: #dispatch node>quot
     children>> [ nodes>quot ] map , \ dispatch , ;
 
-M: #>r node>quot in-d>> length \ >r <repetition> % ;
+M: #>r node>quot
+    [ in-d>> length ] [ out-r>> empty? \ drop \ >r ? ] bi
+    <repetition> % ;
 
-M: #r> node>quot out-d>> length \ r> <repetition> % ;
+DEFER: rdrop
+
+M: #r> node>quot
+    [ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
+    <repetition> % ;
+
+M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
+
+M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
+
+M: #alien-callback node>quot params>> , \ #alien-callback , ;
 
 M: node node>quot drop ;
 

basis/compiler/tree/def-use/def-use-tests.factor

@@ -24,6 +24,11 @@ IN: compiler.tree.def-use.tests
     compute-def-use
     check-nodes ;
 
+: too-deep ( a b -- c )
+    dup [ drop ] [ 2dup too-deep too-deep drop ] if ; inline recursive
+
+[ ] [ [ too-deep ] build-tree normalize compute-def-use check-nodes ] unit-test
+
 ! compute-def-use checks for SSA violations, so we use that to
 ! ensure we generate some common patterns correctly.
 {

basis/compiler/tree/def-use/def-use.factor

@@ -39,22 +39,21 @@ GENERIC: node-uses-values ( node -- values )
 M: #introduce node-uses-values drop f ;
 M: #push node-uses-values drop f ;
 M: #r> node-uses-values in-r>> ;
-M: #phi node-uses-values
+M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
-    [ phi-in-d>> ] [ phi-in-r>> ] bi
-    append concat remove-bottom prune ;
 M: #declare node-uses-values declaration>> keys ;
+M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
+M: #alien-callback node-uses-values drop f ;
 M: node node-uses-values in-d>> ;
 
 GENERIC: node-defs-values ( node -- values )
 
-M: #introduce node-defs-values value>> 1array ;
 M: #>r node-defs-values out-r>> ;
 M: #branch node-defs-values drop f ;
-M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
 M: #declare node-defs-values drop f ;
 M: #return node-defs-values drop f ;
 M: #recursive node-defs-values drop f ;
 M: #terminate node-defs-values drop f ;
+M: #alien-callback node-defs-values drop f ;
 M: node node-defs-values out-d>> ;
 
 : node-def-use ( node -- )

basis/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -57,7 +57,7 @@ SYMBOL: +escaping+
     <value> dup introduce-value ;
 
 : merge-values ( in-values out-value -- )
-    escaping-values get '[ , , equate ] each ;
+    escaping-values get equate-all-with ;
 
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;

basis/compiler/tree/escape-analysis/branches/branches.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences sets fry
+USING: accessors kernel namespaces sequences sets fry columns
 stack-checker.branches
 compiler.tree
 compiler.tree.propagation.branches
@@ -33,6 +33,4 @@ M: #branch escape-analysis*
     2bi ;
 
 M: #phi escape-analysis*
-    [ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]
+    [ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
-    [ [ phi-in-r>> ] [ out-r>> ] bi merge-allocations ]
-    bi ;

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -6,7 +6,8 @@ compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple
-compiler.tree.intrinsics ;
+compiler.tree.intrinsics namespaces compiler.tree.propagation.info
+stack-checker.errors ;
 
 \ escape-analysis must-infer
 
@@ -16,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> { <immutable-tuple-boa> <complex> } memq?
+    dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -295,3 +296,23 @@ C: <ro-box> ro-box
 [ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
 
 [ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
+
+: impeach-node ( quot: ( node -- ) -- )
+    dup slip impeach-node ; inline recursive
+
+: bleach-node ( quot: ( node -- ) -- )
+    [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
+
+[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [
+    [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ \ too-many->r boa f f \ inference-error boa ]
+    count-unboxed-allocations
+] unit-test

basis/compiler/tree/escape-analysis/escape-analysis.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces search-dequeues assocs fry sequences
+USING: kernel namespaces assocs fry sequences
-disjoint-sets
 compiler.tree
-compiler.tree.def-use
 compiler.tree.escape-analysis.allocations
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.branches

basis/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -27,7 +27,7 @@ IN: compiler.tree.escape-analysis.recursive
     out-d>> [ allocation ] map ;
 
 : recursive-stacks ( #enter-recursive -- stacks )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+    recursive-phi-in
     escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
     flip ;
 
@@ -42,14 +42,13 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
-    { 0 } clone [ USE: math
+    [
-        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         child>>
         [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         tri
-    ] curry until-fixed-point ;
+    ] until-fixed-point ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
-combinators dequeues search-dequeues namespaces fry classes
+combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
 compiler.tree
 compiler.tree.intrinsics
@@ -11,13 +11,11 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
-M: #declare escape-analysis* drop ;
-
 M: #terminate escape-analysis* drop ;
 
 M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
 
-M: #introduce escape-analysis* value>> unknown-allocation ;
+M: #introduce escape-analysis* out-d>> unknown-allocations ;
 
 DEFER: record-literal-allocation
 
@@ -42,8 +40,15 @@ M: #push escape-analysis*
     #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
+: record-unknown-allocation ( #call -- )
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocations ] bi ;
+
 : record-tuple-allocation ( #call -- )
-    [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
+    dup immutable-tuple-boa?
+    [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ]
+    [ record-unknown-allocation ]
+    if ;
 
 : record-complex-allocation ( #call -- )
     [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@@ -61,21 +66,17 @@ M: #push escape-analysis*
     ] [ 2drop f ] if ;
 
 : record-slot-call ( #call -- )
-    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over
-    over [
+    [ [ record-slot-access ] [ copy-slot-value ] 3bi ]
-        [ record-slot-access ] [ copy-slot-value ] 3bi
+    [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ]
-    ] [ 2drop unknown-allocation ] if ;
+    if ;
 
 M: #call escape-analysis*
     dup word>> {
-        { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
+        { \ <tuple-boa> [ record-tuple-allocation ] }
         { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
-        [
+        [ drop record-unknown-allocation ]
-            drop
-            [ in-d>> add-escaping-values ]
-            [ out-d>> unknown-allocations ] bi
-        ]
     } case ;
 
 M: #return escape-analysis*
@@ -83,10 +84,12 @@ M: #return escape-analysis*
 
 M: #alien-invoke escape-analysis*
     [ in-d>> add-escaping-values ]
-    [ out-d>> unknown-allocation ]
+    [ out-d>> unknown-allocations ]
     bi ;
 
 M: #alien-indirect escape-analysis*
     [ in-d>> add-escaping-values ]
-    [ out-d>> unknown-allocation ]
+    [ out-d>> unknown-allocations ]
     bi ;
+
+M: #alien-callback escape-analysis* drop ;

basis/compiler/tree/intrinsics/intrinsics.factor

@@ -4,9 +4,6 @@ USING: kernel classes.tuple classes.tuple.private math arrays
 byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple )
-    "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
-
 : (tuple) ( layout -- tuple )
     "BUG: missing (tuple) intrinsic" throw ;
 

basis/compiler/tree/loop/detection/detection.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences namespaces assocs accessors fry
-compiler.tree dequeues search-dequeues ;
+compiler.tree deques search-deques ;
 IN: compiler.tree.loop.detection
 
 ! A loop is a #recursive which only tail calls itself, and those
@@ -82,7 +82,7 @@ M: node collect-loop-info* 2drop ;
             [ loop-calls get at [ disqualify-loop ] each ]
             bi
         ] [ drop ] if
-    ] slurp-dequeue ;
+    ] slurp-deque ;
 
 : detect-loops ( nodes -- nodes )
     dup collect-loop-info disqualify-loops ;

basis/compiler/tree/normalization/normalization-tests.factor

@@ -0,0 +1,48 @@
+IN: compiler.tree.normalization.tests
+USING: compiler.tree.builder compiler.tree.normalization
+compiler.tree compiler.tree.checker
+sequences accessors tools.test kernel math ;
+
+\ count-introductions must-infer
+\ normalize must-infer
+
+[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
+
+[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
+
+[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
+
+[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
+
+: foo ( -- ) swap ; inline recursive
+
+: recursive-inputs ( nodes -- n )
+    [ #recursive? ] find nip child>> first in-d>> length ;
+
+[ 0 2 ] [
+    [ foo ] build-tree
+    [ recursive-inputs ]
+    [ normalize recursive-inputs ] bi
+] unit-test
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize check-nodes ] unit-test
+
+DEFER: bbb
+: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive
+: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive
+
+[ ] [ [ bbb ] build-tree normalize check-nodes ] unit-test
+
+: ccc ( -- ) ccc drop 1 ; inline recursive
+
+[ ] [ [ ccc ] build-tree normalize check-nodes ] unit-test
+
+DEFER: eee
+: ddd ( -- ) eee ; inline recursive
+: eee ( -- ) swap ddd ; inline recursive
+
+[ ] [ [ eee ] build-tree normalize check-nodes ] unit-test
+
+: call-recursive-5 ( -- ) call-recursive-5 ; inline recursive
+
+[ ] [ [ call-recursive-5 swap ] build-tree normalize check-nodes ] unit-test

basis/compiler/tree/normalization/normalization.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
+combinators sequences.deep assocs
 stack-checker.backend
 stack-checker.branches
 stack-checker.inlining
@@ -11,10 +12,9 @@ IN: compiler.tree.normalization
 ! A transform pass done before optimization can begin to
 ! fix up some oddities in the tree output by the stack checker:
 !
-! - We rewrite the code is that #introduce nodes only appear
+! - We rewrite the code so that all #introduce nodes are
-! at the beginning of a program, never having #introduce follow
+! replaced with a single one, at the beginning of a program.
-! any other type of node or appear inside a #branch or
+! This simplifies subsequent analysis.
-! #recursive. This simplifies some types of analysis.
 !
 ! - We collect #return-recursive and #call-recursive nodes and
 ! store them in the #recursive's label slot.
@@ -43,16 +43,20 @@ GENERIC: count-introductions* ( node -- )
         introductions get
     ] with-scope ;
 
-M: #introduce count-introductions* drop introductions inc ;
+: introductions+ ( n -- ) introductions [ + ] change ;
+
+M: #introduce count-introductions*
+    out-d>> length introductions+ ;
 
 M: #branch count-introductions*
     children>>
     [ count-introductions ] map supremum
-    introductions [ + ] change ;
+    introductions+ ;
 
 M: #recursive count-introductions*
     [ label>> ] [ child>> count-introductions ] bi
-    >>introductions drop ;
+    >>introductions
+    drop ;
 
 M: node count-introductions* drop ;
 
@@ -70,88 +74,135 @@ M: #recursive collect-label-info
 
 M: node collect-label-info drop ;
 
-! Eliminate introductions
+! Rename
+SYMBOL: rename-map
+
+: rename-value ( value -- value' )
+    [ rename-map get at ] keep or ;
+
+: rename-values ( values -- values' )
+    rename-map get '[ [ , at ] keep or ] map ;
+
+GENERIC: rename-node-values* ( node -- node )
+
+M: #introduce rename-node-values* ;
+
+M: #shuffle rename-node-values*
+    [ rename-values ] change-in-d
+    [ [ rename-value ] assoc-map ] change-mapping ;
+
+M: #push rename-node-values* ;
+
+M: #r> rename-node-values*
+    [ rename-values ] change-in-r ;
+
+M: #terminate rename-node-values*
+    [ rename-values ] change-in-d
+    [ rename-values ] change-in-r ;
+
+M: #phi rename-node-values*
+    [ [ rename-values ] map ] change-phi-in-d ;
+
+M: #declare rename-node-values*
+    [ [ [ rename-value ] dip ] assoc-map ] change-declaration ;
+
+M: #alien-callback rename-node-values* ;
+
+M: node rename-node-values*
+    [ rename-values ] change-in-d ;
+
+: rename-node-values ( nodes -- nodes' )
+    dup [ rename-node-values* drop ] each-node ;
+
+! Normalize
+GENERIC: normalize* ( node -- node' )
+
 SYMBOL: introduction-stack
 
-: fixup-enter-recursive ( introductions recursive -- )
-    [ child>> first ] [ in-d>> ] bi >>in-d
-    [ append ] change-out-d
-    drop ;
-
-GENERIC: eliminate-introductions* ( node -- node' )
-
 : pop-introduction ( -- value )
     introduction-stack [ unclip-last swap ] change ;
 
-M: #introduce eliminate-introductions*
+: pop-introductions ( n -- values )
-    pop-introduction swap value>> [ 1array ] bi@ #copy ;
+    introduction-stack [ swap cut* swap ] change ;
+
+: add-renamings ( old new -- )
+    [ rename-values ] dip
+    rename-map get '[ , set-at ] 2each ;
+
+M: #introduce normalize*
+    out-d>> [ length pop-introductions ] keep add-renamings f ;
 
 SYMBOL: remaining-introductions
 
-M: #branch eliminate-introductions*
+M: #branch normalize*
-    dup children>> [
+    [
         [
-            [ eliminate-introductions* ] change-each
+            [
-            introduction-stack get
+                [ normalize* ] map flatten
-        ] with-scope
+                introduction-stack get
-    ] map
+                2array
+            ] with-scope
+        ] map unzip swap
+    ] change-children swap
     [ remaining-introductions set ]
     [ [ length ] map infimum introduction-stack [ swap head ] change ]
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
-    [ flip ] dip [
+    [
         [ nip ] [
             dup [ +bottom+ eq? ] left-trim
             [ [ length ] bi@ - tail* ] keep append
         ] if
-    ] 3map flip ;
+    ] 3map ;
 
-M: #phi eliminate-introductions*
+M: #phi normalize*
     remaining-introductions get swap dup terminated>>
     '[ , eliminate-phi-introductions ] change-phi-in-d ;
 
-M: node eliminate-introductions* ;
+: (normalize) ( nodes introductions -- nodes )
-
-: eliminate-introductions ( nodes introductions -- nodes )
     introduction-stack [
-        [ eliminate-introductions* ] map
+        [ normalize* ] map flatten
     ] with-variable ;
 
-: eliminate-toplevel-introductions ( nodes -- nodes' )
+M: #recursive normalize*
-    dup count-introductions make-values
+    dup label>> introductions>>
-    [ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi
+    [ drop [ child>> first ] [ in-d>> ] bi >>in-d drop ]
-    append ;
+    [ make-values '[ , (normalize) ] change-child ]
-
-: eliminate-recursive-introductions ( recursive n -- )
-    make-values
-    [ swap fixup-enter-recursive ]
-    [ '[ , eliminate-introductions ] change-child drop ]
     2bi ;
 
-! Normalize
-GENERIC: normalize* ( node -- node' )
-
-M: #recursive normalize*
-    dup dup label>> introductions>>
-    eliminate-recursive-introductions ;
-
 M: #enter-recursive normalize*
+    [ introduction-stack get prepend ] change-out-d
     dup [ label>> ] keep >>enter-recursive drop
     dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
 
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 
-M: #call-recursive normalize*
+: call<return ( #call-recursive n -- nodes )
-    dup unchanged-underneath
+    neg dup make-values [
-    [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ]
+        [ pop-introductions '[ , prepend ] change-in-d ]
+        [ '[ , prepend ] change-out-d ]
+        bi*
+    ] [ introduction-stack [ prepend ] change ] bi ;
+
+: call>return ( #call-recursive n -- #call-recursive )
+    [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ]
     [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ]
-    2bi 2array ;
+    2bi ;
+
+M: #call-recursive normalize*
+    dup unchanged-underneath {
+        { [ dup 0 < ] [ call<return ] }
+        { [ dup 0 = ] [ drop ] }
+        { [ dup 0 > ] [ call>return ] }
+    } cond ;
 
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
+    H{ } clone rename-map set
     dup [ collect-label-info ] each-node
-    eliminate-toplevel-introductions
+    dup count-introductions make-values
-    [ normalize* ] map-nodes ;
+    [ (normalize) ] [ nip #introduce ] 2bi prefix
+    rename-node-values ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -10,7 +10,8 @@ compiler.tree.dead-code
 compiler.tree.strength-reduction
 compiler.tree.loop.detection
 compiler.tree.loop.inversion
-compiler.tree.branch-fusion ;
+compiler.tree.branch-fusion
+compiler.tree.checker ;
 IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
@@ -18,10 +19,14 @@ IN: compiler.tree.optimizer
     propagate
     cleanup
     detect-loops
-    invert-loops
+    ! invert-loops
-    fuse-branches
+    ! fuse-branches
     escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
-    strength-reduce ;
+    ! strength-reduce
+    ! USE: kernel
+    ! compute-def-use
+    ! dup check-nodes
+    ;

basis/compiler/tree/propagation/branches/branches.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
-math.intervals arrays classes.algebra combinators
+math.intervals arrays classes.algebra combinators columns
 stack-checker.branches
 compiler.tree
-compiler.tree.def-use
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -60,23 +59,17 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[
+    [
-        , [
+        '[
-            [
+            , [
                 dup +bottom+ eq?
                 [ drop null-info ] [ value-info ] if
             ] bind
-        ] 2map
+        ] map
-    ] map ;
+    ] 2map ;
 
 : annotate-phi-inputs ( #phi -- )
-    dup phi-in-d>> compute-phi-input-infos >>phi-info-d
+    dup phi-in-d>> compute-phi-input-infos >>phi-info-d drop ;
-    dup phi-in-r>> compute-phi-input-infos >>phi-info-r
-    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 ;
@@ -84,12 +77,9 @@ SYMBOL: infer-children-data
 SYMBOL: condition-value
 
 M: #phi propagate-before ( #phi -- )
-    {
+    [ annotate-phi-inputs ]
-        [ annotate-phi-inputs ]
+    [ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
-        [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
+    bi ;
-        [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
-        [ annotate-phi-outputs ]
-    } cleave ;
 
 : branch-phi-constraints ( output values booleans -- )
      {
@@ -146,7 +136,9 @@ M: #phi propagate-before ( #phi -- )
 
 M: #phi propagate-after ( #phi -- )
     condition-value get [
-        [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
+        [ out-d>> ]
+        [ phi-in-d>> <flipped> ]
+        [ phi-info-d>> <flipped> ] tri
         [
             [ possible-boolean-values ] map
             branch-phi-constraints

basis/compiler/tree/propagation/copy/copy.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences assocs math kernel accessors fry
-combinators sets locals
+combinators sets locals columns
 stack-checker.branches
 compiler.tree
 compiler.tree.def-use
@@ -49,8 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     ] 2each ;
 
 M: #phi compute-copy-equiv*
-    [ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
+    [ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
-    [ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
 
 M: node compute-copy-equiv* drop ;
 

basis/compiler/tree/propagation/info/info.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes classes.algebra kernel
+USING: assocs classes classes.algebra classes.tuple
-accessors math math.intervals namespaces sequences words
+classes.tuple.private kernel accessors math math.intervals
-combinators combinators.short-circuit arrays
+namespaces sequences words combinators combinators.short-circuit
-compiler.tree.propagation.copy ;
+arrays compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -276,3 +276,9 @@ SYMBOL: value-infos
 
 : node-output-infos ( node -- seq )
     dup out-d>> [ node-value-info ] with map ;
+
+: immutable-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        dup in-d>> peek node-value-info
+        literal>> class>> immutable-tuple-class?
+    ] [ drop f ] if ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -123,23 +123,22 @@ DEFER: (flat-length)
 SYMBOL: history
 
 : remember-inlining ( word -- )
-    history get [ swap suffix ] change ;
+    history [ swap suffix ] change ;
 
-: inline-word ( #call word -- )
+: inline-word ( #call word -- ? )
     dup history get memq? [
-        2drop
+        2drop f
     ] [
         [
             dup remember-inlining
             dupd def>> splicing-nodes >>body
             propagate-body
         ] with-scope
+        t
     ] if ;
 
 : inline-method-body ( #call word -- ? )
-    2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+    2dup should-inline? [ inline-word ] [ 2drop f ] if ;
 
 : always-inline-word? ( word -- ? )
     { curry compose } memq? ;
-
-: always-inline-word ( #call word -- ? ) inline-word t ;

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

@@ -247,13 +247,13 @@ generic-comparison-ops [
             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
         }
     } cond
-    [ fixnum fits? fixnum bignum ? ] keep <class/interval-info>
+    [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
     [ 2nip ] curry +outputs+ set-word-prop
 ] each
 
 { <tuple> <tuple-boa> } [
     [
-        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
+        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip
     ] +outputs+ set-word-prop
 ] each
@@ -263,7 +263,10 @@ generic-comparison-ops [
 ] +outputs+ set-word-prop
 
 ! the output of clone has the same type as the input
-{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
+{ clone (clone) } [
+    [ clone f >>literal f >>literal? ]
+    +outputs+ set-word-prop
+] each
 
 \ slot [
     dup literal?>>
@@ -273,10 +276,10 @@ generic-comparison-ops [
 \ instance? [
     [ value-info ] dip over literal>> class? [
         [ literal>> ] dip predicate-constraints
-    ] [ 2drop f ] if
+    ] [ 3drop f ] if
 ] +constraints+ set-word-prop
 
 \ instance? [
     dup literal>> class?
-    [ literal>> predicate-output-infos ] [ 2drop f ] if
+    [ literal>> predicate-output-infos ] [ 2drop object-info ] if
 ] +outputs+ set-word-prop

basis/compiler/tree/propagation/nodes/nodes.factor

@@ -2,7 +2,6 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors kernel assocs sequences
 compiler.tree
-compiler.tree.def-use
 compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
@@ -14,6 +13,8 @@ GENERIC: propagate-before ( node -- )
 
 GENERIC: propagate-after ( node -- )
 
+GENERIC: annotate-node ( node -- )
+
 GENERIC: propagate-around ( node -- )
 
 : (propagate) ( node -- )
@@ -22,15 +23,14 @@ GENERIC: propagate-around ( node -- )
 : extract-value-info ( values -- assoc )
     [ dup value-info ] H{ } map>assoc ;
 
-: annotate-node ( node -- )
+: (annotate-node) ( node values -- )
-    dup
+    extract-value-info >>info drop ; inline
-    [ 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 annotate-node drop ;
+
 M: node propagate-around
     [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

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

@@ -5,7 +5,8 @@ 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 slots.private words hashtables
+compiler.tree.propagation.info compiler.tree.def-use
+compiler.tree.checker slots.private words hashtables
 classes assocs ;
 IN: compiler.tree.propagation.tests
 
@@ -15,6 +16,8 @@ IN: compiler.tree.propagation.tests
     build-tree
     normalize
     propagate
+    compute-def-use
+    dup check-nodes
     peek node-input-infos ;
 
 : final-classes ( quot -- seq )
@@ -140,10 +143,6 @@ IN: compiler.tree.propagation.tests
     [ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
 ] unit-test
 
-[ V{ string } ] [
-    [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
-] unit-test
-
 [ f ] [ [ t xor ] final-classes first null-class? ] unit-test
 
 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
@@ -156,20 +155,12 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 
-[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
-
 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 
-[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
-
 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 
-[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
-
 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 
-[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
-
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
 [ V{ fixnum } ] [
@@ -271,10 +262,6 @@ IN: compiler.tree.propagation.tests
     [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
 ] unit-test
 
-[ V{ fixnum } ] [
-    [ [ 1 >r ] [ 2 >r ] if r> 3 + ] final-classes
-] unit-test
-
 [ V{ 2 } ] [
     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 ] unit-test
@@ -548,7 +535,7 @@ M: array iterate first t ;
 
 GENERIC: bad-generic ( a -- b )
 M: fixnum bad-generic 1 fixnum+fast ;
-: bad-behavior 4 bad-generic ; inline recursive
+: bad-behavior ( -- b ) 4 bad-generic ; inline recursive
 
 [ V{ fixnum } ] [ [ bad-behavior ] final-classes ] unit-test
 
@@ -557,3 +544,41 @@ M: fixnum bad-generic 1 fixnum+fast ;
         0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
     ] final-classes
 ] unit-test
+
+GENERIC: infinite-loop ( a -- b )
+M: integer infinite-loop infinite-loop ;
+
+[ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
+
+[ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
+
+[ ] [ [ instance? ] final-classes drop ] unit-test
+
+[ f ] [ [ V{ } clone ] final-info first literal?>> ] unit-test
+
+: fold-throw-test ( a -- b ) "A" throw ; foldable
+
+[ ] [ [ 0 fold-throw-test ] final-info drop ] unit-test
+
+: too-deep ( a b -- c )
+    dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
+
+[ ] [ [ too-deep ] final-info drop ] unit-test
+
+[ ] [ [ reversed boa slice boa nth-unsafe * ] final-info drop ] unit-test
+
+MIXIN: empty-mixin
+
+[ ] [ [ { empty-mixin } declare empty-mixin? ] final-info drop ] unit-test
+
+! [ V{ string } ] [
+!     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
+! ] unit-test
+
+! [ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+
+! [ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+
+! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+
+! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test

basis/compiler/tree/propagation/propagation.factor

@@ -2,7 +2,6 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
-compiler.tree.def-use
 compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -52,8 +52,7 @@ IN: compiler.tree.propagation.recursive
     3bi ;
 
 M: #recursive propagate-around ( #recursive -- )
-    { 0 } clone [ USE: math
+    [
-        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         constraints [ clone ] change
 
         child>>
@@ -61,7 +60,7 @@ M: #recursive propagate-around ( #recursive -- )
         [ first propagate-recursive-phi ]
         [ (propagate) ]
         tri
-    ] curry until-fixed-point ;
+    ] until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
@@ -73,6 +72,15 @@ M: #recursive propagate-around ( #recursive -- )
 : return-infos ( node -- infos )
     label>> return>> node-input-infos generalize-return ;
 
-M: #call-recursive propagate-before ( #call-label -- )
+M: #call-recursive propagate-before ( #call-recursive -- )
     [ ] [ return-infos ] [ node-output-infos ] tri
     [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
+
+M: #call-recursive annotate-node
+    dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
+
+M: #enter-recursive annotate-node
+    dup out-d>> (annotate-node) ;
+
+M: #return-recursive annotate-node
+    dup in-d>> (annotate-node) ;

basis/compiler/tree/propagation/simple/simple.factor

@@ -6,7 +6,6 @@ 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
@@ -17,7 +16,7 @@ IN: compiler.tree.propagation.simple
 ! Propagation for straight-line code.
 
 M: #introduce propagate-before
-    value>> object-info swap set-value-info ;
+    out-d>> [ object-info swap set-value-info ] each ;
 
 M: #push propagate-before
     [ literal>> <literal-info> ] [ out-d>> first ] bi
@@ -62,10 +61,10 @@ M: #declare propagate-before
     [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
 
 : fold-call ( #call word -- infos )
-    [ in-d>> [ value-info literal>> ] map ]
+    [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
-    [ [ execute ] curry ]
+    '[ , , with-datastack [ <literal-info> ] map nip ]
-    bi* with-datastack
+    [ drop [ object-info ] replicate ]
-    [ <literal-info> ] map ;
+    recover ;
 
 : predicate-output-infos ( info class -- info )
     [ class>> ] dip {
@@ -94,7 +93,7 @@ M: #declare propagate-before
 
 : do-inlining ( #call word -- ? )
     {
-        { [ dup always-inline-word? ] [ always-inline-word ] }
+        { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }
@@ -109,6 +108,9 @@ M: #call propagate-before
         2bi
     ] if ;
 
+M: #call annotate-node
+    dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
+
 : propagate-input-classes ( node input-classes -- )
     class-infos swap in-d>> refine-value-infos ;
 
@@ -121,3 +123,6 @@ M: #alien-invoke propagate-before
 
 M: #alien-indirect propagate-before
     out-d>> [ object-info swap set-value-info ] each ;
+
+M: #return annotate-node
+    dup in-d>> (annotate-node) ;

basis/compiler/tree/strength-reduction/strength-reduction-tests.factor

@@ -0,0 +1,119 @@
+! 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 ] [
+!     [ hashtable new ] \ new inlined?
+! ] unit-test
+! 
+! [ t ] [
+!     [ dup hashtable eq? [ new ] when ] \ new inlined?
+! ] unit-test
+! 
+! [ f ] [
+!     [ { integer } declare -63 shift 4095 bitand ]
+!     \ shift 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 ] [
+!     [
+!         { 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
+! 
+! [ 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 ] [
+!     [ { 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 ] [
+!     [
+!         { integer } declare [ 256 mod ] map
+!     ] { mod fixnum-mod } 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