Merge branch 'dcn' of git://factorcode.org/git/factor into dcn

basis/alien/parser/parser.factor

@@ -1,18 +1,30 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
 IN: alien.parser
 
+: normalize-c-arg ( type name -- type' name' )
+    [ length ]
+    [
+        [ CHAR: * = ] trim-head
+        [ length - CHAR: * <array> append ] keep
+    ] bi ;
+
 : parse-arglist ( parameters return -- types effect )
-    [ 2 group unzip [ "," ?tail drop ] map ]
+    [
+        2 group [ first2 normalize-c-arg 2array ] map
+        unzip [ "," ?tail drop ] map
+    ]
     [ [ { } ] [ 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+    return function normalize-c-arg function! return!
     function create-in dup reset-generic
     return library function
     parameters return parse-arglist [ function-quot ] dip ;

basis/cairo/ffi/ffi.factor

@@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
 cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
 
 FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
 
 FUNCTION: cairo_status_t
 cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;

basis/calendar/unix/unix.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system ;
 IN: calendar.unix
 
 : timeval>seconds ( timeval -- seconds )
@@ -19,7 +19,7 @@ IN: calendar.unix
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <uint> localtime ;
+    f time <time_t> localtime ;
 
 : timezone-name ( -- string )
     get-time tm-zone ;

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -3,8 +3,7 @@
 USING: kernel math namespaces assocs hashtables sequences arrays
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
-compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.alias-analysis
 
 ! We try to eliminate redundant slot operations using some simple heuristics.
@@ -197,7 +196,7 @@ M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
 
-: init-alias-analysis ( live-in -- )
+: init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
@@ -208,7 +207,7 @@ M: ##alien-global insn-object drop \ ##alien-global ;
     0 ac-counter set
     next-ac heap-ac set
 
-    [ set-heap-ac ] each ;
+    dup local-live-in [ set-heap-ac ] each ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 
@@ -280,9 +279,10 @@ M: insn eliminate-dead-stores* ;
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
 : alias-analysis-step ( insns -- insns' )
+    init-alias-analysis
     analyze-aliases
     compute-live-stores
     eliminate-dead-stores ;
 
 : alias-analysis ( cfg -- cfg' )
-    [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
+    [ alias-analysis-step ] local-optimization ;

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
 compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
-: clone-renamings ( insns -- assoc )
-    [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
-
 : clone-instructions ( insns -- insns' )
-    dup clone-renamings renamings [
+    [ clone dup fresh-insn-temps ] map ;
-        [
-            clone
-            dup rename-insn-defs
-            dup rename-insn-uses
-            dup fresh-insn-temps
-        ] map
-    ] with-variable ;
 
 : clone-basic-block ( bb -- bb' )
     ! The new block gets the same RPO number as the old one.
@@ -62,10 +52,7 @@ IN: compiler.cfg.branch-splitting
 
 UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
 
-: split-instructions? ( insns -- ? )
+: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
-    [ [ irrelevant? not ] count 5 <= ]
-    [ last ##fixnum-overflow? not ]
-    bi and ;
 
 : split-branch? ( bb -- ? )
     {

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -0,0 +1,74 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry kernel make math namespaces sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.builder.blocks
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi
+    begin-local-analysis ;
+
+: initial-basic-block ( -- )
+    <basic-block> set-basic-block ;
+
+: end-basic-block ( -- )
+    basic-block get [ end-local-analysis ] when
+    building off
+    basic-block off ;
+
+: (begin-basic-block) ( -- )
+    <basic-block>
+    basic-block get [ dupd successors>> push ] when*
+    set-basic-block ;
+
+: begin-basic-block ( -- )
+    basic-block get [ end-local-analysis ] when
+    (begin-basic-block) ;
+
+: emit-trivial-block ( quot -- )
+    ##branch begin-basic-block
+    call
+    ##branch begin-basic-block ; inline
+
+: call-height ( #call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-primitive ( node -- )
+    [
+        [ word>> ##call ]
+        [ call-height adjust-d ] bi
+    ] emit-trivial-block ;
+
+: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
+
+: end-branch ( -- pair/f )
+    ! pair is { final-bb final-height }
+    basic-block get dup [
+        ##branch
+        end-local-analysis
+        current-height get clone 2array
+    ] when ;
+
+: with-branch ( quot -- pair/f )
+    [ begin-branch call end-branch ] with-scope ; inline
+
+: set-successors ( branches -- )
+    ! Set the successor of each branch's final basic block to the
+    ! current block.
+    basic-block get dup [
+        '[ [ [ _ ] dip first successors>> push ] when* ] each
+    ] [ 2drop ] if ;
+
+: merge-heights ( branches -- )
+    ! If all elements are f, that means every branch ended with a backward
+    ! jump so the height is irrelevant since this block is unreachable.
+    [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+
+: emit-conditional ( branches -- )
+    ! branchies is a sequence of pairs as above
+    end-basic-block
+    [ merge-heights begin-basic-block ]
+    [ set-successors ]
+    bi ;
+

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

@@ -2,12 +2,21 @@ IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences words sequences.private fry
 prettyprint alien alien.accessors math.private compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg.predecessors compiler.cfg.checker arrays locals
+compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-byte-arrays kernel.private math slots.private ;
+arrays locals byte-arrays kernel.private math slots.private ;
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-cfg ( quot -- )
-    '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
+    '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+
+: blahblah ( nodes -- ? )
+    { fixnum } declare [
+        dup 3 bitand 1 = [ drop t ] [
+            dup 3 bitand 2 = [
+                blahblah
+            ] [ drop f ] if
+        ] if
+    ] any? ; inline recursive
 
 {
     [ ]
@@ -52,6 +61,7 @@ byte-arrays kernel.private math slots.private ;
     [ "int" { "int" } "cdecl" [ ] alien-callback ]
     [ swap - + * ]
     [ swap slot ]
+    [ blahblah ]
 } [
     unit-test-cfg
 ] each

basis/compiler/cfg/builder/builder.factor

@@ -10,30 +10,39 @@ compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.cfg
 compiler.cfg.hats
-compiler.cfg.stacks
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.builder.blocks
+compiler.cfg.stacks
 compiler.alien ;
 IN: compiler.cfg.builder
 
-! Convert tree SSA IR to CFG SSA IR.
+! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
+! constructed later by calling compiler.cfg.ssa:construct-ssa.
 
 SYMBOL: procedures
 SYMBOL: loops
 
-: begin-procedure ( word label -- )
+: begin-cfg ( word label -- cfg )
-    end-basic-block
+    initial-basic-block
-    begin-basic-block
     H{ } clone loops set
-    [ basic-block get ] 2dip
+    [ basic-block get ] 2dip <cfg> dup cfg set ;
-    <cfg> procedures get push ;
+
+: begin-procedure ( word label -- )
+    begin-cfg procedures get push ;
 
 : with-cfg-builder ( nodes word label quot -- )
-    '[ begin-procedure @ ] with-scope ; inline
+    '[
+        begin-stack-analysis
+        begin-procedure
+        @
+        end-stack-analysis
+    ] with-scope ; inline
 
 GENERIC: emit-node ( node -- )
 
@@ -61,17 +70,12 @@ GENERIC: emit-node ( node -- )
 : emit-loop-call ( basic-block -- )
     ##branch
     basic-block get successors>> push
-    basic-block off ;
+    end-basic-block ;
-
-: emit-trivial-block ( quot -- )
-    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
-    call
-    ##branch begin-basic-block ; inline
 
 : emit-call ( word height -- )
     over loops get key?
     [ drop loops get at emit-loop-call ]
-    [ [ ##call ] emit-trivial-block ]
+    [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
     if ;
 
 ! #recursive
@@ -86,7 +90,6 @@ GENERIC: emit-node ( node -- )
     basic-block get swap loops get set-at ;
 
 : emit-loop ( node -- )
-    ##loop-entry
     ##branch
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
@@ -101,9 +104,6 @@ M: #recursive emit-node
 : emit-if ( node -- )
     children>> [ emit-branch ] map emit-conditional ;
 
-: ##branch-t ( vreg -- )
-    \ f tag-number cc/= ##compare-imm-branch ;
-
 : trivial-branch? ( nodes -- value ? )
     dup length 1 = [
         first dup #push? [ literal>> t ] [ drop f f ] if
@@ -127,15 +127,23 @@ M: #recursive emit-node
 : emit-trivial-not-if ( -- )
     ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
 
+: emit-actual-if ( #if -- )
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync
+    ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+
 M: #if emit-node
     {
         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
-        [ ds-pop ##branch-t emit-if ]
+        [ emit-actual-if ]
     } cond ;
 
 ! #dispatch
 M: #dispatch emit-node
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
+    ! though.
     ds-pop ^^offset>slot i ##dispatch emit-if ;
 
 ! #call
@@ -161,15 +169,16 @@ M: #shuffle emit-node
     [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
 
 ! #return
-M: #return emit-node
+: emit-return ( -- )
-    drop ##branch begin-basic-block ##epilogue ##return ;
+    ##branch begin-basic-block ##epilogue ##return ;
+
+M: #return emit-node drop emit-return ;
 
 M: #return-recursive emit-node
-    label>> id>> loops get key?
+    label>> id>> loops get key? [ emit-return ] unless ;
-    [ ##epilogue ##return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop ##no-tco basic-block off ;
+M: #terminate emit-node drop ##no-tco end-basic-block ;
 
 ! FFI
 : return-size ( ctype -- n )
@@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
         [ return>> return-size >>return ]
         [ alien-parameters parameter-sizes drop >>params ] bi ;
 
+: alien-node-height ( params -- )
+    [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
 : emit-alien-node ( node quot -- )
     [
-        [ params>> dup <alien-stack-frame> ] dip call
+        [ params>> dup dup <alien-stack-frame> ] dip call
+        alien-node-height
     ] emit-trivial-block ; inline
 
 M: #alien-invoke emit-node

basis/compiler/cfg/checker/checker.factor

@@ -1,16 +1,18 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators.short-circuit accessors math sequences sets
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
-assocs compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
-compiler.cfg.linearization compiler.cfg.liveness
+compiler.cfg.mr combinators.short-circuit accessors math
-compiler.cfg.utilities ;
+sequences sets assocs ;
 IN: compiler.cfg.checker
 
 ERROR: bad-kill-block bb ;
 
 : check-kill-block ( bb -- )
     dup instructions>> first2
-    swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if
+    swap ##epilogue? [
+        { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
+    ] [ ##branch? ] if
     [ drop ] [ bad-kill-block ] if ;
 
 ERROR: last-insn-not-a-jump bb ;
@@ -27,14 +29,6 @@ ERROR: last-insn-not-a-jump bb ;
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
-ERROR: bad-loop-entry bb ;
-
-: check-loop-entry ( bb -- )
-    dup instructions>> dup length 2 >= [
-        2 head* [ ##loop-entry? ] any?
-        [ bad-loop-entry ] [ drop ] if
-    ] [ 2drop ] if ;
-
 ERROR: bad-kill-insn bb ;
 
 : check-kill-instructions ( bb -- )
@@ -42,10 +36,9 @@ ERROR: bad-kill-insn bb ;
     [ bad-kill-insn ] [ drop ] if ;
 
 : check-normal-block ( bb -- )
-    [ check-loop-entry ]
     [ check-last-instruction ]
     [ check-kill-instructions ]
-    tri ;
+    bi ;
 
 ERROR: bad-successors ;
 
@@ -70,8 +63,6 @@ ERROR: undefined-values uses defs ;
     2dup subset? [ 2drop ] [ undefined-values ] if ;
 
 : check-cfg ( cfg -- )
-    compute-liveness
-    [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
     [ [ check-basic-block ] each-basic-block ]
-    [ flatten-cfg check-mr ]
+    [ build-mr check-mr ]
-    tri ;
+    bi ;

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -1,8 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors ;
+USING: kernel namespaces assocs accessors sequences
+compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
 IN: compiler.cfg.copy-prop
 
+! The first three definitions are also used in compiler.cfg.alias-analysis.
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
@@ -10,3 +12,25 @@ SYMBOL: copies
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
+: collect-copies ( cfg -- )
+    H{ } clone copies set
+    [
+        instructions>>
+        [ dup ##copy? [ record-copy ] [ drop ] if ] each
+    ] each-basic-block ;
+
+: rename-copies ( cfg -- )
+    copies get dup assoc-empty? [ 2drop ] [
+        renamings set
+        [
+            instructions>>
+            [ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here
+        ] each-basic-block
+    ] if ;
+
+: copy-propagation ( cfg -- cfg' )
+    [ collect-copies ]
+    [ rename-copies ]
+    [ ]
+    tri ;

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -0,0 +1,140 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel locals sequences lexer
+namespaces functors compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg ;
+IN: compiler.cfg.dataflow-analysis
+
+GENERIC: join-sets ( sets dfa -- set )
+GENERIC: transfer-set ( in-set bb dfa -- out-set )
+GENERIC: block-order ( cfg dfa -- bbs )
+GENERIC: successors ( bb dfa -- seq )
+GENERIC: predecessors ( bb dfa -- seq )
+
+<PRIVATE
+
+MIXIN: dataflow-analysis
+
+: <dfa-worklist> ( cfg dfa -- queue )
+    block-order <hashed-dlist> [ push-all-front ] keep ;
+
+GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
+
+M: kill-block compute-in-set 3drop f ;
+
+M:: basic-block compute-in-set ( bb out-sets dfa -- set )
+    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+
+:: update-in-set ( bb in-sets out-sets dfa -- ? )
+    bb out-sets dfa compute-in-set
+    bb in-sets maybe-set-at ; inline
+
+GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
+
+M: kill-block compute-out-set 3drop f ;
+
+M:: basic-block compute-out-set ( bb in-sets dfa -- set )
+    bb in-sets at bb dfa transfer-set ;
+
+:: update-out-set ( bb in-sets out-sets dfa -- ? )
+    bb in-sets dfa compute-out-set
+    bb out-sets maybe-set-at ; inline
+
+:: dfa-step ( bb in-sets out-sets dfa work-list -- )
+    bb in-sets out-sets dfa update-in-set [
+        bb in-sets out-sets dfa update-out-set [
+            bb dfa successors work-list push-all-front
+        ] when
+    ] when ; inline
+
+:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+    H{ } clone :> in-sets
+    H{ } clone :> out-sets
+    cfg dfa <dfa-worklist> :> work-list
+    work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+    in-sets
+    out-sets ; inline
+
+M: dataflow-analysis join-sets drop assoc-refine ;
+
+FUNCTOR: define-analysis ( name -- )
+
+name-analysis DEFINES-CLASS ${name}-analysis
+name-ins DEFINES ${name}-ins
+name-outs DEFINES ${name}-outs
+name-in DEFINES ${name}-in
+name-out DEFINES ${name}-out
+
+WHERE
+
+SINGLETON: name-analysis
+
+SYMBOL: name-ins
+
+: name-in ( bb -- set ) name-ins get at ;
+
+SYMBOL: name-outs
+
+: name-out ( bb -- set ) name-outs get at ;
+
+;FUNCTOR
+
+! ! ! Forward dataflow analysis
+
+MIXIN: forward-analysis
+INSTANCE: forward-analysis dataflow-analysis
+
+M: forward-analysis block-order  drop reverse-post-order ;
+M: forward-analysis successors   drop successors>> ;
+M: forward-analysis predecessors drop predecessors>> ;
+
+FUNCTOR: define-forward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis forward-analysis
+
+: compute-name-sets ( cfg -- )
+    name-analysis run-dataflow-analysis
+    [ name-ins set ] [ name-outs set ] bi* ;
+
+;FUNCTOR
+
+! ! ! Backward dataflow analysis
+
+MIXIN: backward-analysis
+INSTANCE: backward-analysis dataflow-analysis
+
+M: backward-analysis block-order  drop post-order ;
+M: backward-analysis successors   drop predecessors>> ;
+M: backward-analysis predecessors drop successors>> ;
+
+FUNCTOR: define-backward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis backward-analysis
+
+: compute-name-sets ( cfg -- )
+    \ name-analysis run-dataflow-analysis
+    [ name-outs set ] [ name-ins set ] bi* ;
+
+;FUNCTOR
+
+PRIVATE>
+
+SYNTAX: FORWARD-ANALYSIS:
+    scan [ define-analysis ] [ define-forward-analysis ] bi ;
+
+SYNTAX: BACKWARD-ANALYSIS:
+    scan [ define-analysis ] [ define-backward-analysis ] bi ;

basis/compiler/cfg/dcn/dcn-tests.factor

@@ -1,621 +0,0 @@
-IN: compiler.cfg.dcn.tests
-USING: tools.test kernel accessors namespaces assocs math
-cpu.architecture vectors sequences classes
-compiler.cfg
-compiler.cfg.utilities
-compiler.cfg.debugger
-compiler.cfg.registers
-compiler.cfg.predecessors
-compiler.cfg.instructions
-compiler.cfg.checker
-compiler.cfg.dcn
-compiler.cfg.dcn.height
-compiler.cfg.dcn.local
-compiler.cfg.dcn.local.private
-compiler.cfg.dcn.global
-compiler.cfg.dcn.global.private
-compiler.cfg.dcn.rewrite ;
-
-: test-local-dcn ( insns -- insns' )
-    <basic-block> swap >>instructions
-    [ local-analysis ] keep
-    instructions>> ;
-
-: inserting-peeks' ( from to -- assoc )
-    [ inserting-peeks ] keep untranslate-locs keys ;
-
-: inserting-replaces' ( from to -- assoc )
-    [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ;
-
-[
-    V{
-        T{ ##copy f V int-regs 1 V int-regs 0 }
-        T{ ##copy f V int-regs 3 V int-regs 2 }
-        T{ ##copy f V int-regs 5 V int-regs 4 }
-        T{ ##inc-d f -1 }
-        T{ ##branch }
-    }
-] [
-    V{
-        T{ ##peek f V int-regs 0 D 0 }
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##inc-d f -1 }
-        T{ ##peek f V int-regs 2 D 0 }
-        T{ ##peek f V int-regs 3 D 0 }
-        T{ ##replace f V int-regs 2 D 0 }
-        T{ ##replace f V int-regs 4 D 1 }
-        T{ ##peek f V int-regs 5 D 1 }
-        T{ ##replace f V int-regs 5 D 1 }
-        T{ ##replace f V int-regs 6 D -1 }
-        T{ ##branch }
-    } test-local-dcn
-] unit-test
-
-[
-    H{
-        { V int-regs 1 V int-regs 0 }
-        { V int-regs 3 V int-regs 2 }
-        { V int-regs 5 V int-regs 4 }
-    }
-] [
-    copies get
-] unit-test
-
-[
-    H{
-        { D 0 V int-regs 0 }
-        { D 1 V int-regs 2 }
-    }
-] [ reads-locations get ] unit-test
-
-[
-    H{
-        { D 0 V int-regs 6 }
-        { D 2 V int-regs 4 }
-    }
-] [ writes-locations get ] unit-test
-
-: test-global-dcn ( -- )
-    cfg new 0 get >>entry
-    compute-predecessors
-    deconcatenatize
-    check-cfg ;
-
-V{ T{ ##epilogue } T{ ##return } } 0 test-bb
-
-[ ] [ test-global-dcn ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##inc-d f 1 }
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 2 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 2 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-
-[ t ] [ 0 get kill-block? ] unit-test
-[ t ] [ 2 get kill-block? ] unit-test
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 0 1 get peek-in key? ] unit-test
-
-[ f ] [ D 0 0 get peek-in key? ] unit-test
-
-[ t ] [ D 0 1 get avail-out key? ] unit-test
-
-[ f ] [ D 0 0 get avail-out key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-
-[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -1 }
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 2 get peek-in key? ] unit-test
-[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f 1 }
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##peek f V int-regs 2 D 1 }
-    T{ ##inc-d f 1 }
-    T{ ##replace f V int-regs 2 D 1 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 4 get V{ } 2sequence >>successors drop
-2 get 3 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ f ] [ D 0 1 get avail-out key? ] unit-test
-[ f ] [ D 1 1 get avail-out key? ] unit-test
-[ t ] [ D 0 4 get peek-in key? ] unit-test
-[ t ] [ D 1 4 get peek-in key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-[ t ] [ D 0 1 get peek-out key? ] unit-test
-[ f ] [ D 1 1 get peek-out key? ] unit-test
-
-[ t ] [ D 1 4 get peek-in key? ] unit-test
-[ f ] [ D 1 4 get avail-in key? ] unit-test
-[ t ] [ D 1 4 get avail-out key? ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##inc-d f -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 100 }
-    T{ ##replace f V int-regs 2 D 1 }
-    T{ ##inc-d f -1 }
-    T{ ##peek f V int-regs 4 D 1 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 3 100 }
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 4 get avail-in key? ] unit-test
-[ f ] [ D 2 4 get avail-in key? ] unit-test
-[ t ] [ D 1 2 get peek-in key? ] unit-test
-[ f ] [ D 1 3 get peek-in key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##call f drop -1 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-[ t ] [ 0 get kill-block? ] unit-test
-[ t ] [ 3 get kill-block? ] unit-test
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 2 get avail-out key? ] unit-test
-[ f ] [ D 1 3 get peek-out key? ] unit-test
-[ f ] [ D 1 3 get avail-out key? ] unit-test
-[ f ] [ D 1 4 get avail-in key? ] unit-test
-
-[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{ T{ ##epilogue } T{ ##return } } 2 test-bb
-
-V{ T{ ##branch } } 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-3 get 1 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 0 1 get avail-out key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##call f drop }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##branch }
-} 5 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 6 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek f V int-regs 2 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 100 }
-    T{ ##replace f V int-regs 2 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-
-[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-! Dead replace elimination
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##replace f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -2 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test
-
-! More dead replace elimination tests
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{    
-    T{ ##peek { dst V int-regs 10 } { loc D 0 } }
-    T{ ##inc-d { n -1 } }
-    T{ ##inc-r { n 1 } }
-    T{ ##replace { src V int-regs 10 } { loc R 0 } }
-    T{ ##peek { dst V int-regs 12 } { loc R 0 } }
-    T{ ##inc-r { n -1 } }
-    T{ ##inc-d { n 1 } }
-    T{ ##replace { src V int-regs 12 } { loc D 0 } }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 2 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-
-! Check that retain stack usage works
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##inc-d f -1 }
-    T{ ##inc-r f 1 }
-    T{ ##replace f V int-regs 0 R 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##call f + -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 R 0 }
-    T{ ##inc-r f -1 }
-    T{ ##inc-d f 1 }
-    T{ ##replace f V int-regs 0 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 4 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ ##replace D 0 ] [
-    3 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test
-
-[ ##replace R 0 ] [
-    1 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test
-
-[ ##peek R 0 ] [
-    2 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test

basis/compiler/cfg/dcn/dcn.factor

@@ -1,44 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators
-compiler.cfg
-compiler.cfg.dcn.height
-compiler.cfg.dcn.local
-compiler.cfg.dcn.global
-compiler.cfg.dcn.rewrite ;
-IN: compiler.cfg.dcn
-
-! "DeConcatenatizatioN" -- dataflow analysis to recover registers
-! from stack locations.
-
-! Local sets:
-! - P(b): locations that block b peeks before replacing
-! - R(b): locations that block b replaces
-! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b
-
-! Global sets:
-! - P_out(b) = /\ P_in(sux) for sux in successors(b)
-! - P_in(b) = (P_out(b) - R(b)) \/ P(b)
-!
-! - R_in(b) = R_out(b) \/ R(b)
-! - R_out(b) = \/ R_in(sux) for sux in successors(b)
-!
-! - A_in(b) = /\ A_out(pred) for pred in predecessors(b)
-! - A_out(b) = A_in(b) \/ P(b) \/ R(b)
-
-! On every edge [b --> sux], insert a replace for each location in
-! R_out(b) - R_in(sux)
-
-! On every edge [pred --> b], insert a peek for each location in
-! P_in(b) - (P_out(pred) \/ A_out(pred))
-
-! Locations are height-normalized.
-
-: deconcatenatize ( cfg -- cfg' )
-    {
-        [ compute-heights ]
-        [ compute-local-sets ]
-        [ compute-global-sets ]
-        [ rewrite ]
-        [ cfg-changed ]
-    } cleave ;

basis/compiler/cfg/dcn/global/global.factor

@@ -1,197 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists fry kernel namespaces sequences
-combinators combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg ;
-IN: compiler.cfg.dcn.global
-
-<PRIVATE
-
-: assoc-refine ( seq -- assoc )
-    [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
-    work-list get '[ _ push-front ] each ;
-
-! Peek analysis. Peek-in is the set of all locations anticipated at
-! the start of a basic block.
-SYMBOLS: peek-ins peek-outs ;
-
-PRIVATE>
-
-: peek-in ( bb -- assoc ) peek-ins get at ;
-: peek-out ( bb -- assoc ) peek-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-peek-in ( bb -- assoc )
-
-M: basic-block compute-peek-in
-    [ [ peek-out ] [ replace ] bi assoc-diff ] [ peek ] bi assoc-union ;
-
-M: kill-block compute-peek-in drop f ;
-
-: update-peek-in ( bb -- ? )
-    [ compute-peek-in ] keep peek-ins get maybe-set-at ;
-
-GENERIC: compute-peek-out ( bb -- assoc )
-
-M: basic-block compute-peek-out
-    successors>> peek-ins get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-peek-out drop f ;
-
-: update-peek-out ( bb -- ? )
-    [ compute-peek-out ] keep peek-outs get maybe-set-at ;
-
-: peek-step ( bb -- )
-    dup update-peek-out [
-        dup update-peek-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-peek-sets ( cfg -- )
-    H{ } clone peek-ins set
-    H{ } clone peek-outs set
-    post-order add-to-work-list work-list get [ peek-step ] slurp-deque ;
-
-! Replace analysis. Replace-in is the set of all locations which
-! will be overwritten at some point after the start of a basic block.
-SYMBOLS: replace-ins replace-outs ;
-
-PRIVATE>
-
-: replace-in ( bb -- assoc ) replace-ins get at ;
-: replace-out ( bb -- assoc ) replace-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-replace-in ( bb -- assoc )
-
-M: basic-block compute-replace-in
-    predecessors>> replace-outs get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-replace-in drop f ;
-
-: update-replace-in ( bb -- ? )
-    [ compute-replace-in ] keep replace-ins get maybe-set-at ;
-
-GENERIC: compute-replace-out ( bb -- assoc )
-
-M: basic-block compute-replace-out
-    [ replace-in ] [ replace ] bi assoc-union ;
-
-M: kill-block compute-replace-out drop f ;
-
-: update-replace-out ( bb -- ? )
-    [ compute-replace-out ] keep replace-outs get maybe-set-at ;
-
-: replace-step ( bb -- )
-    dup update-replace-in [
-        dup update-replace-out
-        [ successors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-replace-sets ( cfg -- )
-    H{ } clone replace-ins set
-    H{ } clone replace-outs set
-    reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ;
-
-! Availability analysis. Avail-out is the set of all locations
-! in registers at the end of a basic block.
-SYMBOLS: avail-ins avail-outs ;
-
-PRIVATE>
-
-: avail-in ( bb -- assoc ) avail-ins get at ;
-: avail-out ( bb -- assoc ) avail-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-avail-in ( bb -- assoc )
-
-M: basic-block compute-avail-in
-    predecessors>> avail-outs get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-avail-in drop f ;
-
-: update-avail-in ( bb -- ? )
-    [ compute-avail-in ] keep avail-ins get maybe-set-at ;
-
-GENERIC: compute-avail-out ( bb -- assoc )
-
-M: basic-block compute-avail-out
-    [ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ;
-
-M: kill-block compute-avail-out drop f ;
-
-: update-avail-out ( bb -- ? )
-    [ compute-avail-out ] keep avail-outs get maybe-set-at ;
-
-: avail-step ( bb -- )
-    dup update-avail-in [
-        dup update-avail-out
-        [ successors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-avail-sets ( cfg -- )
-    H{ } clone avail-ins set
-    H{ } clone avail-outs set
-    reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ;
-
-! Kill analysis. Kill-in is the set of all locations
-! which are going to be overwritten.
-SYMBOLS: kill-ins kill-outs ;
-
-PRIVATE>
-
-: kill-in ( bb -- assoc ) kill-ins get at ;
-: kill-out ( bb -- assoc ) kill-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-kill-in ( bb -- assoc )
-
-M: basic-block compute-kill-in
-    [ kill-out ] [ replace ] bi assoc-union ;
-
-M: kill-block compute-kill-in drop f ;
-
-: update-kill-in ( bb -- ? )
-    [ compute-kill-in ] keep kill-ins get maybe-set-at ;
-
-GENERIC: compute-kill-out ( bb -- assoc )
-
-M: basic-block compute-kill-out
-    successors>> kill-ins get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-kill-out drop f ;
-
-: update-kill-out ( bb -- ? )
-    [ compute-kill-out ] keep kill-outs get maybe-set-at ;
-
-: kill-step ( bb -- )
-    dup update-kill-out [
-        dup update-kill-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-kill-sets ( cfg -- )
-    H{ } clone kill-ins set
-    H{ } clone kill-outs set
-    post-order add-to-work-list work-list get [ kill-step ] slurp-deque ;
-
-PRIVATE>
-
-! Main word
-: compute-global-sets ( cfg -- )
-    <hashed-dlist> work-list set
-    {
-        [ compute-peek-sets ]
-        [ compute-replace-sets ]
-        [ compute-avail-sets ]
-        [ compute-kill-sets ]
-    } cleave ;

basis/compiler/cfg/dcn/height/height.factor

@@ -1,82 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs accessors sequences kernel math locals fry
-compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ;
-IN: compiler.cfg.dcn.height
-
-! Compute block in-height and out-height sets. These are relative to the
-! stack height from the start of the procedure.
-
-<PRIVATE
-
-SYMBOLS: in-ds-heights out-ds-heights in-rs-heights out-rs-heights ;
-
-GENERIC: ds-height-change ( insn -- n )
-
-M: insn ds-height-change drop 0 ;
-
-M: ##inc-d ds-height-change n>> ;
-
-M: ##call ds-height-change height>> ;
-
-: alien-node-height ( node -- n )
-    params>> [ out-d>> length ] [ in-d>> length ] bi - ;
-
-M: ##alien-invoke ds-height-change alien-node-height ;
-
-M: ##alien-indirect ds-height-change alien-node-height ;
-
-GENERIC: rs-height-change ( insn -- n )
-
-M: insn rs-height-change drop 0 ;
-
-M: ##inc-r rs-height-change n>> ;
-
-:: compute-in-height ( bb in out -- )
-    bb predecessors>> [ out at ] map-find drop 0 or
-    bb in set-at ;
-
-:: compute-out-height ( bb in out quot -- )
-    bb instructions>>
-    bb in at
-    [ quot call + ] reduce
-    bb out set-at ; inline
-
-:: compute-height ( bb in out quot -- )
-    bb in get out get
-    [ compute-in-height ]
-    [ quot compute-out-height ] 3bi ; inline
-
-: compute-ds-height ( bb -- )
-    in-ds-heights out-ds-heights [ ds-height-change ] compute-height ;
-
-: compute-rs-height ( bb -- )
-    in-rs-heights out-rs-heights [ rs-height-change ] compute-height ;
-
-PRIVATE>
-
-: compute-heights ( cfg -- )
-    H{ } clone in-ds-heights set
-    H{ } clone out-ds-heights set
-    H{ } clone in-rs-heights set
-    H{ } clone out-rs-heights set
-    [
-        [ compute-rs-height ]
-        [ compute-ds-height ] bi
-    ] each-basic-block ;
-
-GENERIC# translate-loc 1 ( loc bb -- loc' )
-
-M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <rs-loc> ;
-
-: translate-locs ( assoc bb -- assoc' )
-    '[ [ _ translate-loc ] dip ] assoc-map ;
-
-GENERIC# untranslate-loc 1 ( loc bb -- loc' )
-
-M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <rs-loc> ;
-
-: untranslate-locs ( assoc bb -- assoc' )
-    '[ [ _ untranslate-loc ] dip ] assoc-map ;

basis/compiler/cfg/dcn/local/local.factor

@@ -1,101 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel make namespaces sequences math
-compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.dcn.height ;
-IN: compiler.cfg.dcn.local
-
-<PRIVATE
-
-SYMBOL: copies
-
-: record-copy ( dst src -- ) swap copies get set-at ;
-
-: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
-
-SYMBOLS: reads-locations writes-locations ;
-
-: loc>vreg ( loc -- vreg )
-    dup writes-locations get at
-    [ ] [ reads-locations get at ] ?if ;
-
-SYMBOL: ds-height
-
-SYMBOL: rs-height
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc n>> ds-height get - <ds-loc> ;
-
-M: rs-loc translate-loc n>> rs-height get - <rs-loc> ;
-
-GENERIC: visit ( insn -- )
-
-M: insn visit , ;
-
-M: ##inc-d visit n>> ds-height [ + ] change ;
-
-M: ##inc-r visit n>> rs-height [ + ] change ;
-
-M: ##peek visit
-    ! If location is in a register already, copy existing
-    ! register to destination. Otherwise, associate the
-    ! location with the register.
-    [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg
-    [ [ record-copy ] [ ##copy ] 2bi ]
-    [ reads-locations get set-at ]
-    ?if ;
-
-M: ##replace visit
-    ! If location already contains the same value, do nothing.
-    ! Otherwise, associate the location with the register.
-    [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg =
-    [ 2drop ] [ writes-locations get set-at ] if ;
-
-M: ##copy visit
-    ! Not needed at this point because IR doesn't have ##copy
-    ! on input to dcn pass, but in the future it might.
-    [ dst>> ] [ src>> resolve-copy ] bi record-copy ;
-
-: insert-height-changes ( -- )
-    ds-height get dup 0 = [ drop ] [ ##inc-d ] if
-    rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
-
-: init-local-analysis ( -- )
-    0 ds-height set
-    0 rs-height set
-    H{ } clone copies set
-    H{ } clone reads-locations set
-    H{ } clone writes-locations set ;
-
-: local-analysis ( bb -- )
-    ! Removes all ##peek and ##replace from the basic block.
-    ! Conceptually, moves all ##peeks to the start
-    ! (reads-locations assoc) and all ##replaces to the end
-    ! (writes-locations assoc).
-    init-local-analysis
-    [
-        [
-            unclip-last-slice [ [ visit ] each ] dip
-            insert-height-changes
-            ,
-        ] V{ } make
-    ] change-instructions drop ;
-
-SYMBOLS: peeks replaces ;
-
-: visit-block ( bb -- )
-    [ local-analysis ]
-    [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ]
-    [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ]
-    tri ;
-
-PRIVATE>
-
-: peek ( bb -- assoc ) peeks get at ;
-: replace ( bb -- assoc ) replaces get at ;
-
-: compute-local-sets ( cfg -- )
-    H{ } clone peeks set
-    H{ } clone replaces set
-    [ visit-block ] each-basic-block ;

basis/compiler/cfg/debugger/debugger.factor

@@ -7,7 +7,7 @@ parser compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.optimizer
 compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 

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

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel assocs compiler.cfg.instructions ;
+USING: accessors arrays kernel assocs sequences
+sets compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )

basis/compiler/cfg/dominance/dominance-tests.factor

@@ -6,8 +6,7 @@ compiler.cfg.predecessors ;
 : test-dominance ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    compute-dominance
+    compute-dominance ;
-    drop ;
 
 ! Example with no back edges
 V{ } 0 test-bb
@@ -74,3 +73,25 @@ V{ } 5 test-bb
 [ ] [ test-dominance ] unit-test
 
 [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [
+    2 get 3 get 2array iterated-dom-frontier
+    4 get 6 get 2array set=
+] unit-test

basis/compiler/cfg/dominance/dominance.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators sets math fry kernel math.order
-namespaces sequences sorting compiler.cfg.rpo ;
+dlists deques namespaces sequences sorting compiler.cfg.rpo ;
 IN: compiler.cfg.dominance
 
 ! Reference:
@@ -85,8 +85,31 @@ PRIVATE>
 
 PRIVATE>
 
-: compute-dominance ( cfg -- cfg' )
+: compute-dominance ( cfg -- )
     [ compute-dom-parents compute-dom-children ]
     [ compute-dom-frontiers ]
-    [ ]
+    bi ;
-    tri ;
+
+<PRIVATE
+
+SYMBOLS: work-list visited ;
+
+: add-to-work-list ( bb -- )
+    dom-frontier work-list get push-all-front ;
+
+: iterated-dom-frontier-step ( bb -- )
+    dup visited get key? [ drop ] [
+        [ visited get conjoin ]
+        [ add-to-work-list ] bi
+    ] if ;
+
+PRIVATE>
+
+: iterated-dom-frontier ( bbs -- bbs' )
+    [
+        <dlist> work-list set
+        H{ } clone visited set
+        [ add-to-work-list ] each
+        work-list get [ iterated-dom-frontier-step ] slurp-deque
+        visited get keys
+    ] with-scope ;

basis/compiler/cfg/empty-blocks/empty-blocks.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.empty-blocks
+ 
+: update-predecessor ( bb -- )
+    ! We have to replace occurrences of bb with bb's successor
+    ! in bb's predecessor's list of successors.
+    dup predecessors>> first [
+        [
+            2dup eq? [ drop successors>> first ] [ nip ] if
+        ] with map
+    ] change-successors drop ;
+ 
+: update-successor ( bb -- )
+    ! We have to replace occurrences of bb with bb's predecessor
+    ! in bb's sucessor's list of predecessors.
+    dup successors>> first [
+        [
+            2dup eq? [ drop predecessors>> first ] [ nip ] if
+        ] with map
+    ] change-predecessors drop ;
+ 
+: delete-basic-block ( bb -- )
+    [ update-predecessor ] [ update-successor ] bi ;
+ 
+: delete-basic-block? ( bb -- ? )
+    {
+        [ instructions>> length 1 = ]
+        [ predecessors>> length 1 = ]
+        [ successors>> length 1 = ]
+        [ instructions>> first ##branch? ]
+    } 1&& ;
+ 
+: delete-empty-blocks ( cfg -- cfg' )
+    dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
+    cfg-changed ;

basis/compiler/cfg/hats/hats.factor

@@ -18,7 +18,7 @@ IN: compiler.cfg.hats
 : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
 
 : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
 : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
 : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
@@ -74,7 +74,7 @@ IN: compiler.cfg.hats
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
 : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
 
@@ -170,8 +170,6 @@ INSN: ##epilogue ;
 
 INSN: ##branch ;
 
-INSN: ##loop-entry ;
-
 INSN: ##phi < ##pure inputs ;
 
 ! Conditionals
@@ -201,6 +199,7 @@ INSN: _epilogue stack-frame ;
 INSN: _label id ;
 
 INSN: _branch label ;
+INSN: _loop-entry ;
 
 INSN: _dispatch src temp ;
 INSN: _dispatch-label label ;

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -1,10 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences alien math classes.algebra
+USING: accessors kernel sequences alien math classes.algebra fry
-fry locals combinators cpu.architecture
+locals combinators cpu.architecture compiler.tree.propagation.info
-compiler.tree.propagation.info
 compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.alien
 
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
 compiler.tree.propagation.info compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.stacks
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -7,6 +7,7 @@ compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.utilities
+compiler.cfg.builder.blocks
 compiler.cfg.registers
 compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
@@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
     [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
 
 : emit-fixnum-shift-general ( -- )
-    D 0 ^^peek 0 cc> ##compare-imm-branch
+    ds-peek 0 cc> ##compare-imm-branch
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
     2array emit-conditional ;
@@ -62,13 +63,15 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
 
 : emit-no-overflow-case ( dst -- final-bb )
-    [ -2 ##inc-d ds-push ] with-branch ;
+    [ ds-drop ds-drop ds-push ] with-branch ;
 
 : emit-overflow-case ( word -- final-bb )
-    [ -1 ##call ] with-branch ;
+    [ ##call -1 adjust-d ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )
-    [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
+    ! Inputs to the final instruction need to be copied because
+    ! of loc>vreg sync
+    [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
     slots.private:set-slot
     strings.private:string-nth
     strings.private:set-string-nth-fast
-    classes.tuple.private:<tuple-boa>
+    ! classes.tuple.private:<tuple-boa>
-    arrays:<array>
+    ! arrays:<array>
-    byte-arrays:<byte-array>
+    ! byte-arrays:<byte-array>
-    byte-arrays:(byte-array)
+    ! byte-arrays:(byte-array)
-    kernel:<wrapper>
+    ! kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
     alien.accessors:alien-signed-1
@@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
     alien.accessors:set-alien-unsigned-2
     alien.accessors:alien-signed-2
     alien.accessors:set-alien-signed-2
-    alien.accessors:alien-cell
+    ! alien.accessors:alien-cell
     alien.accessors:set-alien-cell
 } [ t "intrinsic" set-word-prop ] each
 
@@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-float
         alien.accessors:alien-double
         alien.accessors:set-alien-double
-    } [ t "intrinsic" set-word-prop ] each ;
+    } drop f [ t "intrinsic" set-word-prop ] each ;
 
 : enable-fixnum-log2 ( -- )
     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences
 classes.algebra compiler.tree.propagation.info
 compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.slots
 
 : value-tag ( info -- n ) class>> class-tag ; inline

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -4,6 +4,7 @@ USING: accessors kernel math assocs namespaces sequences heaps
 fry make combinators sets locals
 cpu.architecture
 compiler.cfg
+compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.registers
@@ -185,6 +186,6 @@ ERROR: bad-vreg vreg ;
         ] V{ } make
     ] change-instructions drop ;
 
-: assign-registers ( live-intervals rpo -- )
+: assign-registers ( live-intervals cfg -- )
     [ init-assignment ] dip
-    [ assign-registers-in-block ] each ;
+    [ assign-registers-in-block ] each-basic-block ;

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -7,7 +7,6 @@ compiler.cfg
 compiler.cfg.optimizer
 compiler.cfg.instructions
 compiler.cfg.registers
-compiler.cfg.liveness
 compiler.cfg.predecessors
 compiler.cfg.rpo
 compiler.cfg.linearization
@@ -1507,9 +1506,7 @@ SYMBOL: linear-scan-result
     [
         cfg new 0 get >>entry
         compute-predecessors
-        compute-liveness
+        dup { { int-regs regs } } (linear-scan)
-        dup reverse-post-order
-        { { int-regs regs } } (linear-scan)
         cfg-changed
         flatten-cfg 1array mr.
     ] with-scope ;
@@ -2331,9 +2328,6 @@ test-diamond
 ! early in bootstrap on x86-32
 [ t ] [
     [
-        H{ } clone live-ins set
-        H{ } clone live-outs set
-        H{ } clone phi-live-ins set
         T{ basic-block
            { id 12345 }
            { instructions
@@ -2353,7 +2347,8 @@ test-diamond
                  T{ ##replace f V int-regs 5 D 0 }
              }
            }
-        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+        } cfg new over >>entry
+        { { int-regs V{ 0 1 2 3 } } } (linear-scan)
         instructions>> first
         live-values>> assoc-empty?
     ] with-scope

basis/compiler/cfg/linear-scan/linear-scan.factor

@@ -4,6 +4,7 @@ USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
@@ -28,17 +29,18 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
-:: (linear-scan) ( rpo machine-registers -- )
+:: (linear-scan) ( cfg machine-registers -- )
-    rpo number-instructions
+    cfg compute-live-sets
-    rpo compute-live-intervals machine-registers allocate-registers
+    cfg number-instructions
-    rpo assign-registers
+    cfg compute-live-intervals machine-registers allocate-registers
-    rpo resolve-data-flow
+    cfg assign-registers
-    rpo check-numbering ;
+    cfg resolve-data-flow
+    cfg check-numbering ;
 
 : linear-scan ( cfg -- cfg' )
     [
         init-mapping
-        dup reverse-post-order machine-registers (linear-scan)
+        dup machine-registers (linear-scan)
         spill-counts get >>spill-counts
         cfg-changed
     ] with-scope ;

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math math.order fry
 combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-range from to ;
@@ -144,10 +145,10 @@ ERROR: bad-live-interval live-interval ;
         } cleave
     ] each ;
 
-: compute-live-intervals ( rpo -- live-intervals )
+: compute-live-intervals ( cfg -- live-intervals )
     H{ } clone [
         live-intervals set
-        <reversed> [ compute-live-intervals-step ] each
+        post-order [ compute-live-intervals-step ] each
     ] keep values dup finish-live-intervals ;
 
 : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )

basis/compiler/cfg/linear-scan/mapping/mapping.factor

@@ -44,17 +44,11 @@ M: register->register >insn
 SYMBOL: froms
 SYMBOL: tos
 
-SINGLETONS: memory register ;
-
-: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-
-: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
-
 : from-reg ( operation -- seq )
-    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+    [ from>> ] [ reg-class>> ] bi 2array ;
 
 : to-reg ( operation -- seq )
-    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+    [ to>> ] [ reg-class>> ] bi 2array ;
 
 : start? ( operations -- pair )
     from-reg tos get key? not ;

basis/compiler/cfg/linear-scan/numbering/numbering.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math sequences grouping namespaces ;
+USING: kernel accessors math sequences grouping namespaces
+compiler.cfg.rpo ;
 IN: compiler.cfg.linear-scan.numbering
 
 : number-instructions ( rpo -- )
@@ -8,7 +9,7 @@ IN: compiler.cfg.linear-scan.numbering
         instructions>> [
             [ (>>insn#) ] [ drop 2 + ] 2bi
         ] each
-    ] each drop ;
+    ] each-basic-block drop ;
 
 SYMBOL: check-numbering?
 
@@ -18,5 +19,5 @@ ERROR: bad-numbering bb ;
     dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
     [ drop ] [ bad-numbering ] if ;
 
-: check-numbering ( rpo -- )
+: check-numbering ( cfg -- )
-    check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;
+    check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;

basis/compiler/cfg/linear-scan/resolve/resolve.factor

@@ -3,10 +3,12 @@
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals
 make math sequences
+compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.linear-scan.assignment
-compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
+compiler.cfg.linear-scan.mapping ;
 IN: compiler.cfg.linear-scan.resolve
 
 : add-mapping ( from to reg-class -- )
@@ -43,5 +45,5 @@ IN: compiler.cfg.linear-scan.resolve
 : resolve-block-data-flow ( bb -- )
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
-: resolve-data-flow ( rpo -- )
+: resolve-data-flow ( cfg -- )
-    [ resolve-block-data-flow ] each ;
+    [ resolve-block-data-flow ] each-basic-block ;

basis/compiler/cfg/linearization/linearization.factor

@@ -4,10 +4,10 @@ USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.liveness
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.utilities ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
@@ -25,7 +25,12 @@ M: insn linearize-insn , drop ;
     #! don't need to branch.
     [ number>> ] bi@ 1 - = ; inline
 
-: emit-branch ( basic-block successor -- )
+: emit-loop-entry? ( bb successor -- ? )
+    [ back-edge? not ]
+    [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ;
+
+: emit-branch ( bb successor -- )
+    2dup emit-loop-entry? [ _loop-entry ] when
     2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
 
 M: ##branch linearize-insn
@@ -33,11 +38,11 @@ M: ##branch linearize-insn
 
 : successors ( bb -- first second ) successors>> first2 ; inline
 
-: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
+: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
     [ dup successors ]
     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
     [ (binary-conditional) ]
     [ drop dup successors>> second useless-branch? ] 2bi
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
@@ -54,7 +59,7 @@ M: ##compare-imm-branch linearize-insn
 M: ##compare-float-branch linearize-insn
     [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
-: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
+: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
     [ dup successors number>> ]
     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
 

basis/compiler/cfg/liveness/authors.txt

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

basis/compiler/cfg/liveness/liveness-tests.factor

@@ -1,15 +1,38 @@
-USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers
+USING: compiler.cfg.liveness compiler.cfg.debugger
-compiler.cfg.liveness accessors tools.test cpu.architecture ;
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.registers compiler.cfg cpu.architecture
+accessors namespaces sequences kernel tools.test ;
 IN: compiler.cfg.liveness.tests
 
+! Sanity check...
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##peek f V int-regs 1 D 1 }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 2 D 0 }
+} 2 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+} 3 test-bb
+
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+
+cfg new 1 get >>entry
+compute-predecessors
+compute-live-sets
+
 [
     H{
-        { "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } }
+        { V int-regs 1 V int-regs 1 }
-        { "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } }
+        { V int-regs 2 V int-regs 2 }
+        { V int-regs 3 V int-regs 3 }
     }
-] [
+]
-    <basic-block> V{
+[ 1 get live-in ]
-        T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } }
+unit-test
-        T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } }
-    } >>instructions compute-phi-live-in
-] unit-test

basis/compiler/cfg/liveness/liveness.factor

@@ -1,79 +1,26 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces deques accessors sets sequences assocs fry
+USING: kernel accessors assocs sequences sets
-hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.def-use compiler.cfg.dataflow-analysis
-compiler.cfg.rpo ;
+compiler.cfg.instructions ;
 IN: compiler.cfg.liveness
 
-! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+! See http://en.wikipedia.org/wiki/Liveness_analysis
+! Do not run after SSA construction
 
-! Assoc mapping basic blocks to sets of vregs
+BACKWARD-ANALYSIS: live
-SYMBOL: live-ins
 
-: live-in ( basic-block -- set ) live-ins get at ;
+: transfer-liveness ( live-set instructions -- live-set' )
+    [ clone ] [ <reversed> ] bi* [
+        [ uses-vregs [ over conjoin ] each ]
+        [ defs-vregs [ over delete-at ] each ] bi
+    ] each ;
 
-! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+: local-live-in ( instructions -- live-set )
-! is in conrrespondence with a predecessor
+    [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ;
-SYMBOL: phi-live-ins
 
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+M: live-analysis transfer-set
+    drop instructions>> transfer-liveness ;
 
-! Assoc mapping basic blocks to sets of vregs
+M: live-analysis join-sets
-SYMBOL: live-outs
+    drop assoc-combine ;
-
-: live-out ( basic-block -- set ) live-outs get at ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
-    work-list get '[ _ push-front ] each ;
-
-: map-unique ( seq quot -- assoc )
-    map concat unique ; inline
-
-: gen-set ( instructions -- seq )
-    [ ##phi? not ] filter [ uses-vregs ] map-unique ;
-
-: kill-set ( instructions -- seq )
-    [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
-
-: compute-live-in ( basic-block -- live-in )
-    dup instructions>>
-    [ [ live-out ] [ gen-set ] bi* assoc-union ]
-    [ nip kill-set ]
-    2bi assoc-diff ;
-
-: compute-phi-live-in ( basic-block -- phi-live-in )
-    instructions>> [ ##phi? ] filter [ f ] [
-        H{ } clone [
-            '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
-        ] keep
-    ] if-empty ;
-
-: update-live-in ( basic-block -- changed? )
-    [ [ compute-live-in ] keep live-ins get maybe-set-at ]
-    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
-    bi and ; 
-
-: compute-live-out ( basic-block -- live-out )
-    [ successors>> [ live-in ] map ]
-    [ dup successors>> [ phi-live-in ] with map ] bi
-    append assoc-combine ;
-
-: update-live-out ( basic-block -- changed? )
-    [ compute-live-out ] keep
-    live-outs get maybe-set-at ;
-
-: liveness-step ( basic-block -- )
-    dup update-live-out [
-        dup update-live-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-liveness ( cfg -- cfg' )
-    <hashed-dlist> work-list set
-    H{ } clone live-ins set
-    H{ } clone phi-live-ins set
-    H{ } clone live-outs set
-    dup post-order add-to-work-list
-    work-list get [ liveness-step ] slurp-deque ;

basis/compiler/cfg/local/authors.txt

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

basis/compiler/cfg/local/local.factor

@@ -1,14 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: locals accessors kernel assocs namespaces
-compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
-IN: compiler.cfg.local
-
-:: optimize-basic-block ( bb init-quot insn-quot -- )
-    bb basic-block set
-    bb live-in keys init-quot call
-    bb insn-quot change-instructions drop ; inline
-
-:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
-    cfg ; inline

basis/compiler/cfg/mr/mr.factor

@@ -1,13 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.gc-checks compiler.cfg.linear-scan
 compiler.cfg.build-stack-frame compiler.cfg.rpo ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
     convert-two-operand
-    compute-liveness
     insert-gc-checks
     linear-scan
     flatten-cfg

basis/compiler/cfg/optimizer/optimizer-tests.factor

@@ -1,8 +1,8 @@
-USING: accessors arrays compiler.cfg.checker
+USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.debugger compiler.cfg.def-use
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer
-compiler.cfg.instructions fry kernel kernel.private math
+fry kernel kernel.private math math.partial-dispatch math.private
-math.partial-dispatch math.private sbufs sequences sequences.private sets
+sbufs sequences sequences.private sets slots.private strings
-slots.private strings strings.private tools.test vectors layouts ;
+strings.private tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
@@ -45,7 +45,7 @@ IN: compiler.cfg.optimizer.tests
         set-string-nth-fast
     ]
 } [
-    [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+    [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test
 ] each
 
 cell 8 = [

basis/compiler/cfg/optimizer/optimizer.factor

@@ -2,21 +2,19 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.tco
-compiler.cfg.predecessors
 compiler.cfg.useless-conditionals
-compiler.cfg.stack-analysis
-compiler.cfg.dcn
-compiler.cfg.dominance
-compiler.cfg.ssa
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
+compiler.cfg.ssa
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
+compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
-compiler.cfg.liveness
-compiler.cfg.rpo
 compiler.cfg.phi-elimination
+compiler.cfg.empty-blocks
+compiler.cfg.predecessors
+compiler.cfg.rpo
 compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
@@ -27,30 +25,24 @@ SYMBOL: check-optimizer?
         dup check-cfg
     ] when ;
 
-SYMBOL: new-optimizer?
-
 : optimize-cfg ( cfg -- cfg' )
     ! Note that compute-predecessors has to be called several times.
     ! The passes that need this document it.
     [
         optimize-tail-calls
-        new-optimizer? get [ delete-useless-conditionals ] unless
+        delete-useless-conditionals
         compute-predecessors
-        new-optimizer? get [ split-branches ] unless
+        split-branches
-        new-optimizer? get [
-            deconcatenatize
-            compute-dominance
-            construct-ssa
-        ] when
         join-blocks
         compute-predecessors
-        new-optimizer? get [ stack-analysis ] unless
+        construct-ssa
-        compute-liveness
         alias-analysis
         value-numbering
         compute-predecessors
+        copy-propagation
         eliminate-dead-code
         eliminate-write-barriers
         eliminate-phis
+        delete-empty-blocks
         ?check
     ] with-scope ;

basis/compiler/cfg/phi-elimination/phi-elimination.factor

@@ -6,6 +6,20 @@ compiler.cfg.utilities compiler.cfg.hats make
 locals ;
 IN: compiler.cfg.phi-elimination
 
+! assoc mapping predecessors to sequences
+SYMBOL: added-instructions
+
+: add-instructions ( predecessor quot -- )
+    [
+        added-instructions get
+        [ drop V{ } clone ] cache
+        building
+    ] dip with-variable ; inline
+
+: insert-basic-blocks ( bb -- )
+    [ added-instructions get ] dip
+    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
+
 : insert-copy ( predecessor input output -- )
     '[ _ _ swap ##copy ] add-instructions ;
 

basis/compiler/cfg/renaming/renaming.factor

@@ -6,7 +6,7 @@ IN: compiler.cfg.renaming
 
 SYMBOL: renamings
 
-: rename-value ( vreg -- vreg' ) renamings get at ;
+: rename-value ( vreg -- vreg' ) renamings get ?at drop ;
 
 GENERIC: rename-insn-defs ( insn -- )
 
@@ -102,6 +102,10 @@ M: ##fixnum-overflow rename-insn-uses
     [ rename-value ] change-src2
     drop ;
 
+M: ##phi rename-insn-uses
+    [ [ rename-value ] assoc-map ] change-inputs
+    drop ;
+
 M: insn rename-insn-uses drop ;
 
 : fresh-vreg ( vreg -- vreg' )

basis/compiler/cfg/rpo/rpo.factor

@@ -33,3 +33,10 @@ SYMBOL: visited
 
 : each-basic-block ( cfg quot -- )
     [ reverse-post-order ] dip each ; inline
+
+: optimize-basic-block ( bb quot -- )
+    [ drop basic-block set ]
+    [ change-instructions drop ] 2bi ; inline
+
+: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+    dupd '[ _ optimize-basic-block ] each-basic-block ; inline

basis/compiler/cfg/ssa/ssa-tests.factor

@@ -5,9 +5,12 @@ compiler.cfg.registers cpu.architecture kernel namespaces sequences
 tools.test vectors ;
 IN: compiler.cfg.ssa.tests
 
-! Reset counters so that results are deterministic w.r.t. hash order
+: reset-counters ( -- )
-0 vreg-counter set-global
+    ! Reset counters so that results are deterministic w.r.t. hash order
-0 basic-block set-global
+    0 vreg-counter set-global
+    0 basic-block set-global ;
+
+reset-counters
 
 V{
     T{ ##load-immediate f V int-regs 1 100 }
@@ -38,7 +41,6 @@ V{
 : test-ssa ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    compute-dominance
     construct-ssa
     drop ;
 
@@ -67,6 +69,9 @@ V{
     }
 ] [ 2 get instructions>> ] unit-test
 
+: clean-up-phis ( insns -- insns' )
+    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
+
 [
     V{
         T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
@@ -75,5 +80,34 @@ V{
     }
 ] [
     3 get instructions>>
-    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
+    clean-up-phis
+] unit-test
+
+reset-counters
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-ssa ] unit-test
+
+[
+    V{
+        T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
+        T{ ##replace f V int-regs 3 D 0 }
+    }
+] [
+    4 get instructions>>
+    clean-up-phis
 ] unit-test

basis/compiler/cfg/ssa/ssa.factor

@@ -1,19 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel accessors sequences fry dlists
+USING: namespaces kernel accessors sequences fry assocs
-deques assocs sets math combinators sorting
+sets math combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.renaming
+compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions ;
 IN: compiler.cfg.ssa
 
-! SSA construction. Predecessors and dominance must be computed first.
+! SSA construction. Predecessors must be computed first.
 
-! This is the classical algorithm based on dominance frontiers:
+! This is the classical algorithm based on dominance frontiers, except
+! we consult liveness information to build pruned SSA:
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
 
 ! Eventually might be worth trying something fancier:
@@ -32,45 +34,22 @@ SYMBOL: inserting-phi-nodes
     '[
         dup instructions>> [
             defs-vregs [
-                _ push-at
+                _ conjoin-at
             ] with each
         ] with each
     ] each-basic-block ;
 
-SYMBOLS: has-already ever-on-work-list work-list ;
-
-: init-insert-phi-nodes ( bbs -- )
-    H{ } clone has-already set
-    [ unique ever-on-work-list set ]
-    [ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
-
-: add-to-work-list ( bb -- )
-    dup ever-on-work-list get key? [ drop ] [
-        [ ever-on-work-list get conjoin ]
-        [ work-list get push-front ]
-        bi
-    ] if ;
-
 : insert-phi-node-later ( vreg bb -- )
+    2dup live-in key? [
         [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
-    inserting-phi-nodes get push-at ;
+        inserting-phi-nodes get push-at
-
+    ] [ 2drop ] if ;
-: compute-phi-node-in ( vreg bb -- )
-    dup has-already get key? [ 2drop ] [
-        [ insert-phi-node-later ]
-        [ has-already get conjoin ]
-        [ add-to-work-list ]
-        tri
-    ] if ;
 
 : compute-phi-nodes-for ( vreg bbs -- )
-    dup length 2 >= [
+    keys dup length 2 >= [
-        init-insert-phi-nodes
+        iterated-dom-frontier [
-        work-list get [
+            insert-phi-node-later
-            dom-frontier [
-                compute-phi-node-in
         ] with each
-        ] with slurp-deque
     ] [ 2drop ] if ;
 
 : compute-phi-nodes ( -- )
@@ -143,4 +122,10 @@ M: ##phi rename-insn
 PRIVATE>
 
 : construct-ssa ( cfg -- cfg' )
-    dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
+    {
+        [ ]
+        [ compute-live-sets ]
+        [ compute-dominance ]
+        [ compute-defs compute-phi-nodes insert-phi-nodes ]
+        [ rename ]
+    } cleave ;

basis/compiler/cfg/stack-analysis/authors.txt

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

basis/compiler/cfg/stack-analysis/merge/merge-tests.factor

@@ -1,104 +0,0 @@
-IN: compiler.cfg.stack-analysis.merge.tests
-USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
- compiler.cfg.instructions compiler.cfg.stack-analysis.state
-compiler.cfg.utilities compiler.cfg compiler.cfg.registers
-compiler.cfg.debugger cpu.architecture make assocs namespaces
-sequences kernel classes ;
-
-[
-    { D 0 }
-    { V int-regs 0 V int-regs 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
-    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    merge-locs locs>vregs>> keys added-phis get values first
-] unit-test
-
-[
-    { D 0 }
-    ##peek
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    <state>
-    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    [ merge-locs locs>vregs>> keys ] { } make drop
-    1 get added-instructions get at first class
-] unit-test
-
-[
-    0 ##inc-d
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-
-    <state> -1 >>ds-height
-    <state> 2array
-
-    [ merge-ds-heights ds-height>> ] { } make drop
-    1 get added-instructions get at first class
-] unit-test
-
-[
-    0
-    { D 0 }
-    { 1 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    
-    [
-        <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
-        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-        [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
-    ] keep
-    [ instructions>> length ] map
-] unit-test
-
-[
-    -1
-    { D -1 }
-    { 1 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    
-    [
-        <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
-        <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
-
-        [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
-        [ ds-height>> ] [ locs>vregs>> keys ] bi
-    ] keep
-    [ instructions>> length ] map
-] unit-test

basis/compiler/cfg/stack-analysis/merge/merge.factor

@@ -1,117 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs sequences accessors fry combinators grouping sets
-arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stack-analysis.state
-compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
-IN: compiler.cfg.stack-analysis.merge
-
-: initial-state ( bb states -- state ) 2drop <state> ;
-
-: single-predecessor ( bb states -- state ) nip first clone ;
-
-: save-ds-height ( n -- )
-    dup 0 = [ drop ] [ ##inc-d ] if ;
-
-: merge-ds-heights ( state predecessors states -- state )
-    [ ds-height>> ] map dup all-equal?
-    [ nip first >>ds-height ]
-    [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
-
-: save-rs-height ( n -- )
-    dup 0 = [ drop ] [ ##inc-r ] if ;
-
-: merge-rs-heights ( state predecessors states -- state )
-    [ rs-height>> ] map dup all-equal?
-    [ nip first >>rs-height ]
-    [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
-
-: assoc-map-keys ( assoc quot -- assoc' )
-    '[ _ dip ] assoc-map ; inline
-
-: translate-locs ( assoc state -- assoc' )
-    '[ _ translate-loc ] assoc-map-keys ;
-
-: untranslate-locs ( assoc state -- assoc' )
-    '[ _ untranslate-loc ] assoc-map-keys ;
-
-: collect-locs ( loc-maps states -- assoc )
-    ! assoc maps locs to sequences
-    [ untranslate-locs ] 2map
-    [ [ keys ] map concat prune ] keep
-    '[ dup _ [ at ] with map ] H{ } map>assoc ;
-
-: insert-peek ( predecessor loc state -- vreg )
-    '[ _ _ translate-loc ^^peek ] add-instructions ;
-
-SYMBOL: added-phis
-
-: add-phi-later ( inputs -- vreg )
-    [ int-regs next-vreg dup ] dip 2array added-phis get push ;
-
-: merge-loc ( predecessors vregs loc state -- vreg )
-    ! Insert a ##phi in the current block where the input
-    ! is the vreg storing loc from each predecessor block
-    '[ [ ] [ _ _ insert-peek ] ?if ] 2map
-    dup all-equal? [ first ] [ add-phi-later ] if ;
-
-:: merge-locs ( state predecessors states -- state )
-    states [ locs>vregs>> ] map states collect-locs
-    [| key value |
-        key
-        predecessors value key state merge-loc
-    ] assoc-map
-    state translate-locs
-    state (>>locs>vregs)
-    state ;
-
-: merge-actual-loc ( vregs -- vreg/f )
-    dup all-equal? [ first ] [ drop f ] if ;
-
-:: merge-actual-locs ( state states -- state )
-    states [ actual-locs>vregs>> ] map states collect-locs
-    [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
-    state translate-locs
-    state (>>actual-locs>vregs)
-    state ;
-
-: merge-changed-locs ( state states -- state )
-    [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
-    over translate-locs
-    >>changed-locs ;
-
-:: insert-phis ( bb -- )
-    bb predecessors>> :> predecessors
-    [
-        added-phis get [| dst inputs |
-            dst predecessors inputs zip ##phi
-        ] assoc-each
-    ] V{ } make bb instructions>> over push-all
-    bb (>>instructions) ;
-
-:: multiple-predecessors ( bb states -- state )
-    states [ not ] any? [
-        <state>
-        bb add-to-work-list
-    ] [
-        [
-            H{ } clone added-instructions set
-            V{ } clone added-phis set
-            bb predecessors>> :> predecessors
-            state new
-            predecessors states merge-ds-heights
-            predecessors states merge-rs-heights
-            predecessors states merge-locs
-            states merge-actual-locs
-            states merge-changed-locs
-            bb insert-basic-blocks
-            bb insert-phis
-        ] with-scope
-    ] if ;
-
-: merge-states ( bb states -- state )
-    dup length {
-        { 0 [ initial-state ] }
-        { 1 [ single-predecessor ] }
-        [ drop multiple-predecessors ]
-    } case ;

basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

@@ -1,204 +0,0 @@
-USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
-compiler.cfg.predecessors compiler.cfg.stack-analysis
-compiler.cfg.instructions sequences kernel tools.test accessors
-sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers
-sets namespaces arrays cpu.architecture ;
-IN: compiler.cfg.stack-analysis.tests
-
-! Fundamental invariant: a basic block should not load or store a value more than once
-: test-stack-analysis ( quot -- cfg )
-    dup cfg? [ test-cfg first ] unless
-    compute-predecessors
-    stack-analysis
-    dup check-cfg ;
-
-: linearize ( cfg -- mr )
-    flatten-cfg instructions>> ;
-
-[ ] [ [ ] test-stack-analysis drop ] unit-test
-
-! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
-
-! Redundant replace is redundant
-[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Replace required here
-[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Only one replace, at the end
-[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
-
-! Do we support the full language?
-[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
-[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
-[ ] [
-    [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
-    test-cfg second test-stack-analysis drop
-] unit-test
-
-! Test loops
-[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
-
-! Make sure that peeks are inserted in the right place
-[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
-
-! This should be a total no-op
-[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Don't insert inc-d/inc-r; that's wrong!
-[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
-
-! Bug in height tracking
-[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
-
-! Bugs with code that throws
-[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
-[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
-
-! Make sure the replace stores a value with the right height
-[ ] [
-    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
-    [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
-] unit-test
-
-! translate-loc was the wrong way round
-[ ] [
-    [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##load-immediate? ] count 2 assert= ]
-    [ [ ##peek? ] count 1 assert= ]
-    [ [ ##replace? ] count 3 assert= ]
-    tri
-] unit-test
-
-[ ] [
-    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##load-immediate? ] count 2 assert= ]
-    [ [ ##peek? ] count 1 assert= ]
-    [ [ ##replace? ] count 1 assert= ]
-    tri
-] unit-test
-
-! Sync before a back-edge, not after
-! ##peeks should be inserted before a ##loop-entry
-! Don't optimize out the constants
-[ t ] [
-    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
-    [ ##load-immediate? ] any?
-] unit-test
-
-! Correct height tracking
-[ t ] [
-    [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 4 swap nth
-    instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
-    2array { D 1 D 0 } set=
-] unit-test
-
-[ D 1 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 2 }
-        T{ ##inc-d f -1 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> first loc>>
-] unit-test
-
-! Do inserted ##peeks reference the correct stack location if
-! an ##inc-d/r was also inserted?
-[ D 0 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{
-        T{ ##call f \ + -1 }
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
-] unit-test
-
-! Missing ##replace
-[ t ] [
-    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    reverse-post-order last
-    instructions>> [ ##replace? ] filter [ loc>> ] map
-    { D 0 D 1 D 2 } set=
-] unit-test
-
-! Inserted ##peeks reference the wrong stack location
-[ t ] [
-    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    eliminate-dead-code reverse-post-order 4 swap nth
-    instructions>> [ ##peek? ] filter [ loc>> ] map
-    { D 0 D 1 } set=
-] unit-test
-
-[ D 0 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
-] unit-test

basis/compiler/cfg/stack-analysis/stack-analysis.factor

@@ -1,124 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators dlists deques
-compiler.cfg
-compiler.cfg.copy-prop
-compiler.cfg.def-use
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.cfg.rpo
-compiler.cfg.hats
-compiler.cfg.stack-analysis.state
-compiler.cfg.stack-analysis.merge
-compiler.cfg.utilities ;
-IN: compiler.cfg.stack-analysis
-
-SYMBOL: global-optimization?
-
-: redundant-replace? ( vreg loc -- ? )
-    dup state get untranslate-loc n>> 0 <
-    [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
-
-: save-changed-locs ( state -- )
-    [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
-        dup _ at swap 2dup redundant-replace?
-        [ 2drop ] [ state get untranslate-loc ##replace ] if
-    ] each ;
-
-: sync-state ( -- )
-    state get {
-        [ ds-height>> save-ds-height ]
-        [ rs-height>> save-rs-height ]
-        [ save-changed-locs ]
-        [ clear-state ]
-    } cleave ;
-
-! Abstract interpretation
-GENERIC: visit ( insn -- )
-
-M: ##inc-d visit
-    n>> state get [ + ] change-ds-height drop ;
-
-M: ##inc-r visit
-    n>> state get [ + ] change-rs-height drop ;
-
-! Instructions which don't have any effect on the stack
-UNION: neutral-insn
-    ##effect
-    ##flushable
-    ##no-tco ;
-
-M: neutral-insn visit , ;
-
-UNION: sync-if-back-edge
-    ##branch
-    ##conditional-branch
-    ##compare-imm-branch
-    ##dispatch
-    ##loop-entry
-    ##fixnum-overflow ;
-
-: sync-state? ( -- ? )
-    basic-block get successors>>
-    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
-
-M: sync-if-back-edge visit
-    global-optimization? get [ sync-state? [ sync-state ] when ] unless
-    , ;
-
-: eliminate-peek ( dst src -- )
-    ! the requested stack location is already in 'src'
-    [ ##copy ] [ swap copies get set-at ] 2bi ;
-
-M: ##peek visit
-    [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
-    [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
-
-M: ##replace visit
-    [ src>> resolve ] [ loc>> state get translate-loc ] bi
-    record-replace ;
-
-M: ##copy visit
-    [ call-next-method ] [ record-copy ] bi ;
-
-M: ##jump visit sync-state , ;
-
-M: ##return visit sync-state , ;
-
-M: ##callback-return visit sync-state , ;
-
-M: kill-vreg-insn visit sync-state , ;
-
-! Maps basic-blocks to states
-SYMBOL: state-out
-
-: block-in-state ( bb -- states )
-    dup predecessors>> state-out get '[ _ at ] map merge-states ;
-
-: set-block-out-state ( state bb -- )
-    [ clone ] dip state-out get set-at ;
-
-: visit-block ( bb -- )
-    ! block-in-state may add phi nodes at the start of the basic block
-    ! so we wrap the whole thing with a 'make'
-    [
-        dup basic-block set
-        dup block-in-state
-        state [
-            [ instructions>> [ visit ] each ]
-            [ [ state get ] dip set-block-out-state ]
-            [ ]
-            tri
-        ] with-variable
-    ] V{ } make >>instructions drop ;
-
-: stack-analysis ( cfg -- cfg' )
-    [
-        <hashed-dlist> work-list set
-        H{ } clone copies set
-        H{ } clone state-out set
-        dup [ visit-block ] each-basic-block
-        global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
-        cfg-changed
-    ] with-scope ;

basis/compiler/cfg/stack-analysis/state/state.factor

@@ -1,53 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math deques
-compiler.cfg.registers ;
-IN: compiler.cfg.stack-analysis.state
-
-TUPLE: state
-locs>vregs actual-locs>vregs changed-locs
-{ ds-height integer }
-{ rs-height integer }
-poisoned? ;
-
-: <state> ( -- state )
-    state new
-        H{ } clone >>locs>vregs
-        H{ } clone >>actual-locs>vregs
-        H{ } clone >>changed-locs
-        0 >>ds-height
-        0 >>rs-height ;
-
-M: state clone
-    call-next-method
-        [ clone ] change-locs>vregs
-        [ clone ] change-actual-locs>vregs
-        [ clone ] change-changed-locs ;
-
-: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
-
-: record-peek ( dst loc -- )
-    state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
-
-: changed-loc ( loc -- )
-    state get changed-locs>> conjoin ;
-
-: record-replace ( src loc -- )
-    dup changed-loc state get locs>vregs>> set-at ;
-
-: clear-state ( state -- )
-    0 >>ds-height 0 >>rs-height
-    [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
-    [ clear-assoc ] tri@ ;
-
-GENERIC# translate-loc 1 ( loc state -- loc' )
-M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
-
-GENERIC# untranslate-loc 1 ( loc state -- loc' )
-M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( bb -- ) work-list get push-front ;

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -2,29 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs kernel fry accessors sequences make math
 combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local
+compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
-compiler.cfg.dcn.global compiler.cfg.dcn.height ;
+compiler.cfg.stacks.global compiler.cfg.stacks.height ;
-IN: compiler.cfg.dcn.rewrite
+IN: compiler.cfg.stacks.finalize
 
-! This pass inserts peeks, replaces, and copies. All stack locations
+! This pass inserts peeks and replaces.
-! are loaded to canonical vregs, with a 1-1 mapping from location to
-! vreg. SSA is reconstructed afterwards.
 
 : inserting-peeks ( from to -- assoc )
     peek-in swap [ peek-out ] [ avail-out ] bi
     assoc-union assoc-diff ;
 
-: remove-dead-stores ( assoc -- assoc' )
-    [ drop n>> 0 >= ] assoc-filter ;
-
 : inserting-replaces ( from to -- assoc )
     [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
     assoc-union assoc-diff ;
 
-SYMBOL: locs>vregs
-
-: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
-
 : each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
     '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
 
@@ -42,30 +33,9 @@ ERROR: bad-peek dst loc ;
     2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
     [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
 
-: visit-edges ( bb -- )
+: visit-block ( bb -- )
     [ predecessors>> ] keep '[ _ visit-edge ] each ;
 
-: insert-in-copies ( bb -- )
+: finalize-stack-shuffling ( cfg -- cfg' )
-    peek [ swap loc>vreg ##copy ] assoc-each ;
+    dup [ visit-block ] each-basic-block
-
+    cfg-changed ;
-: insert-out-copies ( bb -- )
-    replace [ swap loc>vreg swap ##copy ] assoc-each ;
-
-: rewrite-instructions ( bb -- )
-    [
-        [
-            {
-                [ insert-in-copies ]
-                [ instructions>> but-last-slice % ]
-                [ insert-out-copies ]
-                [ instructions>> last , ]
-            } cleave
-        ] V{ } make
-    ] keep (>>instructions) ;
-
-: visit-block ( bb -- )
-    [ visit-edges ] [ rewrite-instructions ] bi ;
-
-: rewrite ( cfg -- )
-    H{ } clone locs>vregs set
-    [ visit-block ] each-basic-block ;

basis/compiler/cfg/stacks/global/global.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel combinators compiler.cfg.dataflow-analysis
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.stacks.global
+
+! Peek analysis. Peek-in is the set of all locations anticipated at
+! the start of a basic block.
+BACKWARD-ANALYSIS: peek
+
+M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+
+! Replace analysis. Replace-in is the set of all locations which
+! will be overwritten at some point after the start of a basic block.
+FORWARD-ANALYSIS: replace
+
+M: replace-analysis transfer-set drop replace-set assoc-union ;
+
+! Availability analysis. Avail-out is the set of all locations
+! in registers at the end of a basic block.
+FORWARD-ANALYSIS: avail
+
+M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+
+! Kill analysis. Kill-in is the set of all locations
+! which are going to be overwritten.
+BACKWARD-ANALYSIS: kill
+
+M: kill-analysis transfer-set drop replace-set assoc-union ;
+
+! Main word
+: compute-global-sets ( cfg -- cfg' )
+    {
+        [ compute-peek-sets ]
+        [ compute-replace-sets ]
+        [ compute-avail-sets ]
+        [ compute-kill-sets ]
+        [ ]
+    } cleave ;

basis/compiler/cfg/stacks/height/height.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel math
+namespaces compiler.cfg.registers ;
+IN: compiler.cfg.stacks.height
+
+! Global stack height tracking done while constructing CFG.
+SYMBOLS: ds-heights rs-heights ;
+
+: record-stack-heights ( ds-height rs-height bb -- )
+    [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
+
+GENERIC# translate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
+
+: translate-locs ( assoc bb -- assoc' )
+    '[ [ _ translate-loc ] dip ] assoc-map ;
+
+GENERIC# untranslate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
+
+: untranslate-locs ( assoc bb -- assoc' )
+    '[ [ _ untranslate-loc ] dip ] assoc-map ;

basis/compiler/cfg/stacks/local/local.factor

@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math namespaces sets make sequences
+compiler.cfg
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.stacks.height
+compiler.cfg.parallel-copy ;
+IN: compiler.cfg.stacks.local
+
+! Local stack analysis. We build local peek and replace sets for every basic
+! block while constructing the CFG.
+
+SYMBOLS: peek-sets replace-sets ;
+
+SYMBOL: locs>vregs
+
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
+
+TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+
+SYMBOLS: local-peek-set local-replace-set replace-mapping ;
+
+GENERIC: translate-local-loc ( loc -- loc' )
+M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
+M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
+
+: emit-stack-changes ( -- )
+    replace-mapping get dup assoc-empty? [ drop ] [
+        [ [ loc>vreg ] dip ] assoc-map parallel-copy
+    ] if ;
+
+: emit-height-changes ( -- )
+    current-height get
+    [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
+    [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
+
+: emit-changes ( -- )
+    ! Insert height and stack changes prior to the last instruction
+    building get pop
+    emit-stack-changes
+    emit-height-changes
+    , ;
+
+! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
+: inc-d ( n -- )
+    current-height get
+    [ [ + ] change-emit-d drop ]
+    [ [ + ] change-d drop ]
+    2bi ;
+
+: inc-r ( n -- )
+    current-height get
+    [ [ + ] change-emit-r drop ]
+    [ [ + ] change-r drop ]
+    2bi ;
+
+: peek-loc ( loc -- vreg )
+    translate-local-loc
+    dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
+    dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+
+: replace-loc ( vreg loc -- )
+    translate-local-loc
+    2dup loc>vreg =
+    [ nip replace-mapping get delete-at ]
+    [
+        [ local-replace-set get conjoin ]
+        [ replace-mapping get set-at ]
+        bi
+    ] if ;
+
+: begin-local-analysis ( -- )
+    H{ } clone local-peek-set set
+    H{ } clone local-replace-set set
+    H{ } clone replace-mapping set
+    current-height get 0 >>emit-d 0 >>emit-r drop
+    current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+
+: end-local-analysis ( -- )
+    emit-changes
+    local-peek-set get basic-block get peek-sets get set-at
+    local-replace-set get basic-block get replace-sets get set-at ;
+
+: clone-current-height ( -- )
+    current-height [ clone ] change ;
+
+: peek-set ( bb -- assoc ) peek-sets get at ;
+: replace-set ( bb -- assoc ) replace-sets get at ;

basis/compiler/cfg/stacks/stacks.factor

@@ -1,45 +1,76 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math sequences kernel cpu.architecture
+USING: math sequences kernel namespaces accessors biassocs compiler.cfg
-compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
-compiler.cfg.hats ;
+compiler.cfg.predecessors compiler.cfg.stacks.local
+compiler.cfg.stacks.height compiler.cfg.stacks.global
+compiler.cfg.stacks.finalize ;
 IN: compiler.cfg.stacks
 
-: ds-drop ( -- )
+: begin-stack-analysis ( -- )
-    -1 ##inc-d ;
+    <bihash> locs>vregs set
+    H{ } clone ds-heights set
+    H{ } clone rs-heights set
+    H{ } clone peek-sets set
+    H{ } clone replace-sets set
+    current-height new current-height set ;
 
-: ds-pop ( -- vreg )
+: end-stack-analysis ( -- )
-    D 0 ^^peek -1 ##inc-d ;
+    cfg get
+    compute-predecessors
+    compute-global-sets
+    finalize-stack-shuffling
+    drop ;
 
-: ds-push ( vreg -- )
+: ds-drop ( -- ) -1 inc-d ;
-    1 ##inc-d D 0 ##replace ;
+
+: ds-peek ( -- vreg ) D 0 peek-loc ;
+
+: ds-pop ( -- vreg ) ds-peek ds-drop ;
+
+: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
 
 : ds-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
+    [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
 
 : ds-store ( vregs -- )
     [
         <reversed>
-        [ length ##inc-d ]
+        [ length inc-d ]
-        [ [ <ds-loc> ##replace ] each-index ] bi
+        [ [ <ds-loc> replace-loc ] each-index ] bi
     ] unless-empty ;
 
+: rs-drop ( -- ) -1 inc-r ;
+
 : rs-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
+    [ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
 
 : rs-store ( vregs -- )
     [
         <reversed>
-        [ length ##inc-r ]
+        [ length inc-r ]
-        [ [ <rs-loc> ##replace ] each-index ] bi
+        [ [ <rs-loc> replace-loc ] each-index ] bi
     ] unless-empty ;
 
+: (2inputs) ( -- vreg1 vreg2 )
+    D 1 peek-loc D 0 peek-loc ;
+
 : 2inputs ( -- vreg1 vreg2 )
-    D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
+    (2inputs) -2 inc-d ;
+
+: (3inputs) ( -- vreg1 vreg2 vreg3 )
+    D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
 
 : 3inputs ( -- vreg1 vreg2 vreg3 )
-    D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
+    (3inputs) -3 inc-d ;
+
+! adjust-d/adjust-r: these are called when other instructions which
+! internally adjust the stack height are emitted, such as ##call and
+! ##alien-invoke
+: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
+: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
+

basis/compiler/cfg/two-operand/two-operand.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences make compiler.cfg.instructions
-compiler.cfg.local cpu.architecture ;
+compiler.cfg.rpo cpu.architecture ;
 IN: compiler.cfg.two-operand
 
 ! On x86, instructions take the form x = x op y
@@ -54,7 +54,6 @@ M: insn convert-two-operand* , ;
 
 : convert-two-operand ( cfg -- cfg' )
     two-operand? [
-        [ drop ]
         [ [ [ convert-two-operand* ] each ] V{ } make ]
         local-optimization
     ] when ;

basis/compiler/cfg/utilities/utilities.factor

@@ -20,42 +20,6 @@ IN: compiler.cfg.utilities
         } cond
     ] [ drop f ] if ;
 
-: set-basic-block ( basic-block -- )
-    [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
-    <basic-block> basic-block get [
-        dupd successors>> push
-    ] when*
-    set-basic-block ;
-
-: end-basic-block ( -- )
-    building off
-    basic-block off ;
-
-: emit-trivial-block ( quot -- )
-    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
-    call
-    ##branch begin-basic-block ; inline
-
-: call-height ( #call -- n )
-    [ out-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-primitive ( node -- )
-    [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ;
-
-: with-branch ( quot -- final-bb )
-    [
-        begin-basic-block
-        call
-        basic-block get dup [ ##branch ] when
-    ] with-scope ; inline
-
-: emit-conditional ( branches -- )
-    end-basic-block
-    begin-basic-block
-    basic-block get '[ [ _ swap successors>> push ] when* ] each ;
-
 PREDICATE: kill-block < basic-block
     instructions>> {
         [ length 2 = ]
@@ -84,16 +48,6 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-! assoc mapping predecessors to sequences
-SYMBOL: added-instructions
-
-: add-instructions ( predecessor quot -- )
-    [
-        added-instructions get
-        [ drop V{ } clone ] cache
-        building
-    ] dip with-variable ; inline
-
 :: insert-basic-block ( from to bb -- )
     bb from 1vector >>predecessors drop
     bb to 1vector >>successors drop
@@ -105,7 +59,3 @@ SYMBOL: added-instructions
     swap >vector
     \ ##branch new-insn over push
     >>instructions ;
-
-: insert-basic-blocks ( bb -- )
-    [ added-instructions get ] dip
-    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -6,7 +6,6 @@ compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
 ! Referentially-transparent expressions
-TUPLE: expr op ;
 TUPLE: unary-expr < expr in ;
 TUPLE: binary-expr < expr in1 in2 ;
 TUPLE: commutative-expr < binary-expr ;
@@ -37,17 +36,6 @@ M: reference-expr equal?
         } cond
     ] [ 2drop f ] if ;
 
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( class -- expr )
-    input-expr-counter [ dup 1 + ] change input-expr boa ;
-
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )
@@ -97,7 +85,7 @@ M: ##compare-imm >expr compare-imm>expr ;
 
 M: ##compare-float >expr compare>expr ;
 
-M: ##flushable >expr class next-input-expr ;
+M: ##flushable >expr drop next-input-expr ;
 
 : init-expressions ( -- )
     0 input-expr-counter set ;

basis/compiler/cfg/value-numbering/graph/graph.factor

@@ -10,13 +10,24 @@ SYMBOL: vn-counter
 ! biassoc mapping expressions to value numbers
 SYMBOL: exprs>vns
 
+TUPLE: expr op ;
+
 : expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
 
 : vn>expr ( vn -- expr ) exprs>vns get value-at ;
 
+! Expressions whose values are inputs to the basic block.
+TUPLE: input-expr < expr n ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- expr )
+    f input-expr-counter counter input-expr boa ;
+
 SYMBOL: vregs>vns
 
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+: vreg>vn ( vreg -- vn )
+    vregs>vns get [ drop next-input-expr expr>vn ] cache ;
 
 : vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
 

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite
 
 ! Outputs f to mean no change
 
-GENERIC: rewrite* ( insn -- insn/f )
+GENERIC: rewrite ( insn -- insn/f )
 
-: rewrite ( insn -- insn' )
+M: insn rewrite drop f ;
-    dup [ number-values ] [ rewrite* ] bi
-    [ rewrite ] [ ] ?if ;
-
-M: insn rewrite* drop f ;
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
@@ -123,7 +119,7 @@ ERROR: bad-comparison ;
 : fold-compare-imm-branch ( insn -- insn/f )
     (fold-compare-imm) fold-branch ;
 
-M: ##compare-imm-branch rewrite*
+M: ##compare-imm-branch rewrite
     {
         { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite*
 : rewrite-self-compare-branch ( insn -- insn' )
     (rewrite-self-compare) fold-branch ;
 
-M: ##compare-branch rewrite*
+M: ##compare-branch rewrite
     {
         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
@@ -185,7 +181,7 @@ M: ##compare-branch rewrite*
 : rewrite-self-compare ( insn -- insn' )
     dup (rewrite-self-compare) >boolean-insn ;
 
-M: ##compare rewrite*
+M: ##compare rewrite
     {
         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
@@ -196,7 +192,7 @@ M: ##compare rewrite*
 : fold-compare-imm ( insn -- insn' )
     dup (fold-compare-imm) >boolean-insn ;
 
-M: ##compare-imm rewrite*
+M: ##compare-imm rewrite
     {
         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ;
     ] dip
     over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
 
-M: ##add-imm rewrite*
+M: ##add-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
@@ -249,7 +245,7 @@ M: ##add-imm rewrite*
     [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
     [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 
-M: ##sub-imm rewrite*
+M: ##sub-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ sub-imm>add-imm ]
@@ -261,7 +257,7 @@ M: ##sub-imm rewrite*
 : strength-reduce-mul? ( insn -- ? )
     src2>> power-of-2? ;
 
-M: ##mul-imm rewrite*
+M: ##mul-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
@@ -269,40 +265,40 @@ M: ##mul-imm rewrite*
         [ drop f ]
     } cond ;
 
-M: ##and-imm rewrite*
+M: ##and-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##or-imm rewrite*
+M: ##or-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##xor-imm rewrite*
+M: ##xor-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##shl-imm rewrite*
+M: ##shl-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
     } cond ;
 
-M: ##shr-imm rewrite*
+M: ##shr-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
     } cond ;
 
-M: ##sar-imm rewrite*
+M: ##sar-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
@@ -327,7 +323,7 @@ M: ##sar-imm rewrite*
         [ 2drop f ]
     } cond ; inline
 
-M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
+M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
 
 : subtraction-identity? ( insn -- ? )
     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
@@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
 : rewrite-subtraction-identity ( insn -- insn' )
     dst>> 0 \ ##load-immediate new-insn ;
 
-M: ##sub rewrite*
+M: ##sub rewrite
     {
         { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
         [ \ ##sub-imm rewrite-arithmetic ]
     } cond ;
 
-M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
+M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
 
-M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
+M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
 
-M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
+M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
 
-M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
+M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
 
-M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
+M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
 
-M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
+M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
 
-M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
+M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -127,7 +127,5 @@ M: expr simplify* drop f ;
         { [ dup integer? ] [ nip ] }
     } cond ;
 
-GENERIC: number-values ( insn -- )
+: number-values ( insn -- )
-
+    [ >expr simplify ] [ dst>> ] bi set-vn ;
-M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
-M: insn number-values drop ;

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
 accessors sequences compiler.cfg.predecessors locals
-compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness
+compiler.cfg.phi-elimination compiler.cfg.dce
 compiler.cfg assocs vectors arrays layouts namespaces ;
 
 : trim-temps ( insns -- insns )
@@ -15,10 +15,6 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         } 1|| [ f >>temp ] when
     ] map ;
 
-: test-value-numbering ( insns -- insns )
-    { } init-value-numbering
-    value-numbering-step ;
-
 ! Folding constants together
 [
     {
@@ -33,15 +29,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 -0.0 }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-reference f V int-regs 0 0.0 }
-        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##copy f V int-regs 1 V int-regs 0 }
         T{ ##replace f V int-regs 0 D 0 }
-        T{ ##replace f V int-regs 0 D 1 }
+        T{ ##replace f V int-regs 1 D 1 }
     }
 ] [
     {
@@ -49,15 +45,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 0.0 }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-reference f V int-regs 0 t }
-        T{ ##load-reference f V int-regs 1 t }
+        T{ ##copy f V int-regs 1 V int-regs 0 }
         T{ ##replace f V int-regs 0 D 0 }
-        T{ ##replace f V int-regs 0 D 1 }
+        T{ ##replace f V int-regs 1 D 1 }
     }
 ] [
     {
@@ -65,22 +61,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 t }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
+    } value-numbering-step
-] unit-test
-
-! Copy propagation
-[
-    {
-        T{ ##peek f V int-regs 45 D 1 }
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 45 D 1 }
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
-    } test-value-numbering
 ] unit-test
 
 ! Compare propagation
@@ -89,8 +70,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
-        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##copy f V int-regs 6 V int-regs 4 }
-        T{ ##replace f V int-regs 4 D 0 }
+        T{ ##replace f V int-regs 6 D 0 }
     }
 ] [
     {
@@ -99,7 +80,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -117,7 +98,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
         T{ ##replace f V int-regs 6 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -139,7 +120,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
         T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
         T{ ##replace f V int-regs 14 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -155,7 +136,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
         T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 ! Immediate operand conversion
@@ -170,7 +151,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -184,7 +165,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -198,7 +179,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -210,7 +191,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -224,7 +205,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -238,7 +219,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -250,7 +231,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
     {
         T{ ##peek f V int-regs 1 D 0 }
         T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -264,7 +245,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -278,7 +259,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -292,7 +273,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -306,7 +287,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -320,7 +301,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -334,7 +315,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -348,7 +329,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -362,7 +343,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -376,7 +357,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -390,7 +371,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 ! Reassociation
@@ -409,7 +390,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -427,7 +408,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -445,7 +426,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -463,7 +444,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -481,7 +462,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -499,7 +480,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -517,7 +498,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -535,7 +516,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -553,7 +534,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -571,7 +552,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -589,7 +570,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -607,7 +588,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 ! Simplification
@@ -616,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -626,7 +607,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -634,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -644,7 +625,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -652,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -662,7 +643,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -670,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -680,15 +661,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 1 }
-        T{ ##shl-imm f V int-regs 2 V int-regs 0 0 }
+        T{ ##copy f V int-regs 2 V int-regs 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 2 D 0 }
     }
 ] [
     {
@@ -696,7 +677,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##replace f V int-regs 2 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 ! Constant folding
@@ -713,7 +694,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -729,7 +710,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -745,7 +726,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -761,7 +742,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 1 }
         T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -777,7 +758,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 1 }
         T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -793,7 +774,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -807,7 +788,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 cell 8 = [
@@ -822,7 +803,7 @@ cell 8 = [
             T{ ##peek f V int-regs 0 D 0 }
             T{ ##load-immediate f V int-regs 1 -1 }
             T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 ] when
 
@@ -837,7 +818,7 @@ cell 8 = [
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 -8 }
         T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 cell 8 = [
@@ -854,7 +835,7 @@ cell 8 = [
             T{ ##load-immediate f V int-regs 1 65536 }
             T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 
     [
@@ -868,7 +849,7 @@ cell 8 = [
             T{ ##peek f V int-regs 0 D 0 }
             T{ ##load-immediate f V int-regs 2 140737488355328 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 
     [
@@ -884,7 +865,7 @@ cell 8 = [
             T{ ##load-immediate f V int-regs 2 2147483647 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
             T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 ] when
 
@@ -900,7 +881,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -914,7 +895,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -928,7 +909,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -942,7 +923,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -954,7 +935,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -966,7 +947,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -978,7 +959,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -990,7 +971,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -1002,7 +983,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -1014,12 +995,12 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 : test-branch-folding ( insns -- insns' n )
     <basic-block>
-    [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
+    [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
     successors>> first ;
 
 [
@@ -1208,7 +1189,6 @@ test-diamond
 
 [ ] [
     cfg new 0 get >>entry
-    compute-liveness
     value-numbering
     compute-predecessors
     eliminate-phis drop
@@ -1253,7 +1233,6 @@ test-diamond
 [ ] [
     cfg new 0 get >>entry
     compute-predecessors
-    compute-liveness
     value-numbering
     compute-predecessors
     eliminate-dead-code
@@ -1324,7 +1303,7 @@ V{
 
 [ ] [
     cfg new 0 get >>entry
-    compute-liveness value-numbering eliminate-dead-code drop
+    value-numbering eliminate-dead-code drop
 ] unit-test
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test

basis/compiler/cfg/value-numbering/value-numbering.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
+USING: namespaces assocs kernel accessors
-sorting sets sequences fry
+sorting sets sequences
 compiler.cfg
-compiler.cfg.local
+compiler.cfg.rpo
-compiler.cfg.liveness
+compiler.cfg.instructions
-compiler.cfg.renaming
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.simplify
@@ -13,27 +12,28 @@ compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
 ! Local value numbering. Predecessors must be recomputed after this
+: >copy ( insn -- insn/##copy )
+    dup dst>> dup vreg>vn vn>vreg
+    2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
 
-: number-input-values ( live-in -- )
+: rewrite-loop ( insn -- insn' )
-    [ [ f next-input-expr simplify ] dip set-vn ] each ;
+    dup rewrite [ rewrite-loop ] [ ] ?if ;
 
-: init-value-numbering ( live-in -- )
+GENERIC: process-instruction ( insn -- insn' )
-    init-value-graph
-    init-expressions
-    number-input-values ;
 
-: vreg>vreg-mapping ( -- assoc )
+M: ##flushable process-instruction
-    vregs>vns get [ keys ] keep
+    dup rewrite
-    '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
+    [ process-instruction ]
+    [ dup number-values >copy ] ?if ;
 
-: rename-uses ( insns -- )
+M: insn process-instruction
-    vreg>vreg-mapping renamings [
+    dup rewrite
-        [ rename-insn-uses ] each
+    [ process-instruction ] [ ] ?if ;
-    ] with-variable ;
 
 : value-numbering-step ( insns -- insns' )
-    [ rewrite ] map dup rename-uses ;
+    init-value-graph
+    init-expressions
+    [ process-instruction ] map ;
 
 : value-numbering ( cfg -- cfg' )
-    [ init-value-numbering ] [ value-numbering-step ] local-optimization
+    [ value-numbering-step ] local-optimization cfg-changed ;
-    cfg-changed ;

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,42 +1,43 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors ;
+arrays tools.test vectors compiler.cfg kernel accessors
+compiler.cfg.utilities ;
 IN: compiler.cfg.write-barrier.tests
 
 : test-write-barrier ( insns -- insns )
-    write-barriers-step ;
+    <simple-block> dup write-barriers-step instructions>> ;
 
 [
-    {
+    V{
         T{ ##peek f V int-regs 4 D 0 f }
-        T{ ##copy f V int-regs 6 V int-regs 4 f }
         T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
         T{ ##load-immediate f V int-regs 9 8 f }
         T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
-        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+        T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
         T{ ##replace f V int-regs 7 D 0 f }
+        T{ ##branch }
     }
 ] [
     {
         T{ ##peek f V int-regs 4 D 0 }
-        T{ ##copy f V int-regs 6 V int-regs 4 }
         T{ ##allot f V int-regs 7 24 array V int-regs 8 }
         T{ ##load-immediate f V int-regs 9 8 }
         T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
         T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
-        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+        T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
         T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
         T{ ##replace f V int-regs 7 D 0 }
     } test-write-barrier
 ] unit-test
 
 [
-    {
+    V{
         T{ ##load-immediate f V int-regs 4 24 }
         T{ ##peek f V int-regs 5 D -1 }
         T{ ##peek f V int-regs 6 D -2 }
         T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
         T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+        T{ ##branch }
     }
 ] [
     {
@@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests
 ] unit-test
 
 [
-    {
+    V{
         T{ ##peek f V int-regs 19 D -3 }
         T{ ##peek f V int-regs 22 D -2 }
-        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
-        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
-        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
-        T{ ##copy f V int-regs 26 V int-regs 19 }
         T{ ##peek f V int-regs 28 D -1 }
-        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
-        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+        T{ ##branch }
     }
 ] [
     {
         T{ ##peek f V int-regs 19 D -3 }
         T{ ##peek f V int-regs 22 D -2 }
-        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
-        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
-        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
-        T{ ##copy f V int-regs 26 V int-regs 19 }
         T{ ##peek f V int-regs 28 D -1 }
-        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
-        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
-        T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
     } test-write-barrier
 ] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences locals
+USING: kernel accessors namespaces assocs sets sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
-compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -14,33 +13,27 @@ SYMBOL: safe
 ! Objects which have been mutated
 SYMBOL: mutated
 
-GENERIC: eliminate-write-barrier ( insn -- insn' )
+GENERIC: eliminate-write-barrier ( insn -- ? )
 
 M: ##allot eliminate-write-barrier
-    dup dst>> safe get conjoin ;
+    dst>> safe get conjoin t ;
 
 M: ##write-barrier eliminate-write-barrier
-    dup src>> resolve dup
+    src>> dup [ safe get key? not ] [ mutated get key? ] bi and
-    [ safe get key? not ]
+    [ safe get conjoin t ] [ drop f ] if ;
-    [ mutated get key? ] bi and
-    [ safe get conjoin ] [ 2drop f ] if ;
-
-M: ##copy eliminate-write-barrier
-    dup record-copy ;
 
 M: ##set-slot eliminate-write-barrier
-    dup obj>> resolve mutated get conjoin ;
+    obj>> mutated get conjoin t ;
 
 M: ##set-slot-imm eliminate-write-barrier
-    dup obj>> resolve mutated get conjoin ;
+    obj>> mutated get conjoin t ;
 
-M: insn eliminate-write-barrier ;
+M: insn eliminate-write-barrier drop t ;
 
-: write-barriers-step ( insns -- insns' )
+: write-barriers-step ( bb -- )
     H{ } clone safe set
     H{ } clone mutated set
-    H{ } clone copies set
+    instructions>> [ eliminate-write-barrier ] filter-here ;
-    [ eliminate-write-barrier ] map sift ;
 
 : eliminate-write-barriers ( cfg -- cfg' )
-    [ drop ] [ write-barriers-step ] local-optimization ;
+    dup [ write-barriers-step ] each-basic-block ;

basis/compiler/codegen/codegen.factor

@@ -245,7 +245,7 @@ M: _gc generate-insn
         [ gc-root-count>> ]
     } cleave %gc ;
 
-M: ##loop-entry generate-insn drop %loop-entry ;
+M: _loop-entry generate-insn drop %loop-entry ;
 
 M: ##alien-global generate-insn
     [ dst>> register ] [ symbol>> ] [ library>> ] tri

basis/compiler/tests/codegen.factor

@@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 [ 4294967295 B{ 255 255 255 255 } -1 ]
 [
     -1 <int> -1 <int>
-    [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+    [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
     compile-call
 ] unit-test
 
@@ -322,3 +322,15 @@ cell 4 = [
 
 ! Regression from Slava's value numbering changes
 [ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! Bug with ##return node construction
+: return-recursive-bug ( nodes -- ? )
+    { fixnum } declare [
+        dup 3 bitand 1 = [ drop t ] [
+            dup 3 bitand 2 = [
+                return-recursive-bug
+            ] [ drop f ] if
+        ] if
+    ] any? ; inline recursive
+
+[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test

basis/functors/functors.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser
+USING: accessors arrays classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.parser combinators effects
+classes.tuple classes.tuple.parser combinators effects effects.parser
-effects.parser fry generic generic.parser generic.standard
+fry generic generic.parser generic.standard interpolate
-interpolate io.streams.string kernel lexer locals.parser
+io.streams.string kernel lexer locals.parser locals.rewrite.closures
-locals.rewrite.closures locals.types make namespaces parser
+locals.types make namespaces parser quotations sequences vocabs.parser
-quotations sequences vocabs.parser words words.symbol ;
+words words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -71,6 +71,14 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
+SYNTAX: `SINGLETON:
+    scan-param parsed
+    \ define-singleton-class parsed ;
+
+SYNTAX: `MIXIN:
+    scan-param parsed
+    \ define-mixin-class parsed ;
+
 SYNTAX: `M:
     scan-param parsed
     scan-param parsed
@@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter
 : functor-words ( -- assoc )
     H{
         { "TUPLE:" POSTPONE: `TUPLE: }
+        { "SINGLETON:" POSTPONE: `SINGLETON: }
+        { "MIXIN:" POSTPONE: `MIXIN: }
         { "M:" POSTPONE: `M: }
         { "C:" POSTPONE: `C: }
         { ":" POSTPONE: `: }

basis/math/bitwise/bitwise.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
+USING: arrays assocs combinators combinators.smart fry kernel
-math.bits sequences.private words namespaces macros
+macros math math.bits sequences sequences.private words ;
-hints combinators fry io.binary combinators.smart ;
 IN: math.bitwise
 
 ! utilities
@@ -104,14 +103,6 @@ PRIVATE>
 : bit-count ( x -- n )
     dup 0 < [ bitnot ] when (bit-count) ; inline
 
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1 - on-bits ] bi
-    2dup > [ bitnot bitor ] [ drop ] if ;
-
-: signed-be> ( bytes -- x )
-    <reversed> signed-le> ;
-
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 

basis/opengl/capabilities/capabilities-docs.factor

@@ -40,7 +40,13 @@ HELP: gl-extensions
 
 HELP: has-gl-extensions?
 { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
+{ $examples "Testing for framebuffer object and pixel buffer support:"
+    { $code <" {
+    { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
+    "GL_ARB_pixel_buffer_object"
+} has-gl-extensions? "> }
+} ;
 
 HELP: has-gl-version-or-extensions?
 { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }

basis/opengl/capabilities/capabilities-tests.factor

@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: opengl.capabilities tools.test ;
+IN: opengl.capabilities.tests
+
+CONSTANT: test-extensions
+    {
+        "GL_ARB_vent_core_frogblast"
+        "GL_EXT_resonance_cascade"
+        "GL_EXT_slipgate"
+    }
+
+[ t ]
+[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
+
+[ f ]
+[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
+
+[ t ] [
+    { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
+    test-extensions (has-extension?)
+] unit-test

basis/opengl/capabilities/capabilities.factor

@@ -1,16 +1,19 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order fry ;
+continuations math.parser math arrays sets strings math.order fry ;
 IN: opengl.capabilities
 
 : (require-gl) ( thing require-quot make-error-quot -- )
     [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
 
+: (has-extension?) ( query-extension(s) available-extensions -- ? )
+    over string?  [ member? ] [ [ member? ] curry any? ] if ;
+
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;
 : has-gl-extensions? ( extensions -- ? )
-    gl-extensions swap [ over member? ] all? nip ;
+    gl-extensions [ (has-extension?) ] curry all? ;
 : (make-gl-extensions-error) ( required-extensions -- )
     gl-extensions diff
     "Required OpenGL extensions not supported:\n" %

basis/unix/types/freebsd/freebsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 
 IN: unix.types
 
@@ -22,3 +22,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>

basis/unix/types/linux/linux.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 TYPEDEF: ulonglong __uquad_type
@@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t
 TYPEDEF: ulonglong __fsfilcnt64_t
 TYPEDEF: ulonglong ino64_t
 TYPEDEF: ulonglong off64_t
+
+ALIAS: <time_t> <long>

basis/unix/types/macosx/macosx.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! Darwin 9.1.0
@@ -21,3 +21,5 @@ TYPEDEF: __int32_t  blksize_t
 TYPEDEF: long       ssize_t
 TYPEDEF: __int32_t  pid_t
 TYPEDEF: long       time_t
+
+ALIAS: <time_t> <long>

basis/unix/types/netbsd/netbsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax combinators layouts vocabs.loader ;
+USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
 IN: unix.types
 
 ! NetBSD 4.0
@@ -17,6 +17,8 @@ TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
 
+ALIAS: <time_t> <int>
+
 cell-bits {
     { 32 [ "unix.types.netbsd.32" require ] }
     { 64 [ "unix.types.netbsd.64" require ] }

basis/unix/types/openbsd/openbsd.factor

@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! OpenBSD 4.2
@@ -17,3 +17,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>

basis/x11/xlib/xlib.factor

@@ -477,7 +477,7 @@ C-STRUCT: XImage
     { "XImage-funcs" "f" } ;
 
 X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
 
 : XImage-size ( ximage -- size )
     [ XImage-height ] [ XImage-bytes_per_line ] bi * ;

core/assocs/assocs-tests.factor

@@ -134,3 +134,19 @@ unit-test
 [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
 [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
 [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
+
+[ H{ { 1 2 } { 2 3 } } ] [
+    {
+        H{ { 1 3 } }
+        H{ { 2 3 } }
+        H{ { 1 2 } }
+    } assoc-combine
+] unit-test
+
+[ H{ { 1 7 } } ] [
+    {
+        H{ { 1 2 } { 2 4 } { 5 6 } }
+        H{ { 1 3 } { 2 5 } }
+        H{ { 1 7 } { 5 6 } }
+    } assoc-refine
+] unit-test

core/assocs/assocs.factor

@@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-combine ( seq -- union )
     H{ } clone [ dupd update ] reduce ;
 
+: assoc-refine ( seq -- assoc )
+    [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
+
 : assoc-diff ( assoc1 assoc2 -- diff )
     [ nip key? not ] curry assoc-filter ;
 

core/io/binary/binary.factor

@@ -24,3 +24,10 @@ IN: io.binary
 : h>b/b ( h -- b1 b2 )
     [ mask-byte ]
     [ -8 shift mask-byte ] bi ;
+
+: signed-le> ( bytes -- x )
+    [ le> ] [ length 8 * 1 - 2^ 1 - ] bi
+    2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+    <reversed> signed-le> ;

extra/alien/cxx/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/cxx.factor

@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+    create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+    "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+    [ drop class-wrapper { } define-tuple-class ]
+    [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+    [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+    add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+    [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make           :> name'
+    effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+    types class-name "*" append suffix                  :> types'
+    effect in>> "," join                                :> args
+    class-name virtual [ "#" append ] unless current-vocab lookup                  :> class
+    SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+    name' types' effect' body define-c-marshalled
+    class generic create-method name' current-vocab lookup 1quotation define ;

extra/alien/cxx/parser/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/parser/parser.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+    scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+    scan scan-word function-types-effect ;

extra/alien/cxx/syntax/authors.txt

@@ -0,0 +1 @@
+Jeremy Hughes

extra/alien/cxx/syntax/syntax-tests.factor

@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+    return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+RAW-C:
+class alpha {
+    public:
+    alpha(const char* s) {
+        str = s;
+    };
+    const char* render() {
+        return str;
+    };
+    virtual const char* chop() {
+        return str;
+    };
+    virtual int length() {
+        return strlen(str);
+    };
+    const char* str;
+};
+
+class beta : alpha {
+    public:
+    beta(const char* s) : alpha(s + 1) { };
+    const char* render() {
+        return str + 1;
+    };
+    virtual const char* chop() {
+        return str + 2;
+    };
+};
+;
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+    return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+    return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test

extra/alien/cxx/syntax/syntax.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+    parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+    parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+    parse-c++-method-definition t define-c++-method ;

extra/alien/inline/types/types.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types assocs combinators.short-circuit
 continuations effects fry kernel math memoize sequences
-splitting ;
+splitting strings peg.ebnf make ;
 IN: alien.inline.types
 
 : cify-type ( str -- str' )
@@ -21,6 +21,9 @@ IN: alien.inline.types
 : pointer-to-const? ( str -- ? )
     cify-type "const " head? ;
 
+: template-class? ( str -- ? )
+    [ CHAR: < = ] any? ;
+
 MEMO: resolved-primitives ( -- seq )
     primitive-types [ resolve-typedef ] map ;
 
@@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
         [ over pointer-to-primitive? [ ">" prepend ] when ]
         assoc-map unzip
     ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig  = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+    factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+    [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+    [
+        [ name>> % ]
+        [ params>> [ params>string % ] when* ]
+        [ ptr>> [ "*" % ] when ]
+        tri
+    ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;

extra/alien/marshall/marshall-docs.factor

@@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
     "for all types except pointers to non-const primitives."
 } ;
 
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
 { $values
     { "type" " a C type string" }
     { "quot" quotation }

extra/alien/marshall/marshall.factor

@@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
 specialized-arrays.short specialized-arrays.uchar
 specialized-arrays.uint specialized-arrays.ulong
 specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations math ;
 IN: alien.marshall
 
 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@@ -19,6 +20,9 @@ filter [ define-primitive-marshallers ] each >>
 
 TUPLE: alien-wrapper { underlying alien } ;
 TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
 
 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
 
@@ -27,6 +31,8 @@ M: struct-wrapper unmarshall-cast ;
 
 M: struct-wrapper dispose* underlying>> free ;
 
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
 : marshall-pointer ( obj -- alien )
     {
         { [ dup alien? ] [ ] }
@@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer
 : ?malloc-byte-array ( c-type -- alien )
     dup alien? [ malloc-byte-array ] unless ;
 
-: struct-unmarshaller ( type -- quot )
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
-    current-vocab lookup [
+    type type-quot call current-vocab lookup [
-        dup superclasses [ \ struct-wrapper = ] any? [
+        dup superclasses superclass swap member?
-            '[ ?malloc-byte-array _ new swap >>underlying ]
+        [ def call ] [ drop clean call f ] if
-        ] [ drop [ ] ] if
+    ] [ clean call f ] if* ; inline
-    ] [ [ ] ] if* ;
 
-: pointer-unmarshaller ( type -- quot )
+: struct-unmarshaller ( type -- quot/f )
-    type-sans-pointer current-vocab lookup [
+    [ ] \ struct-wrapper
-        dup superclasses [ \ alien-wrapper = ] any? [
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
-            '[ _ new swap >>underlying unmarshall-cast ]
+    [ ]
-        ] [ drop [ ] ] if
+    x-unmarshaller ;
-    ] [ [ ] ] if* ;
+
+: class-unmarshaller ( type -- quot/f )
+    [ type-sans-pointer "#" append ] \ class-wrapper
+    [ '[ _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+    {
+        { [ dup pointer? ] [ class-unmarshaller ] }
+        [ struct-unmarshaller ]
+    } cond ;
 
 : unmarshaller ( type -- quot )
-    factorize-type dup primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : struct-field-unmarshaller ( type -- quot )
-    factorize-type dup struct-primitive-unmarshaller [ nip ] [
+    factorize-type {
-        dup pointer?
+        [ struct-primitive-unmarshaller ]
-        [ pointer-unmarshaller ]
+        [ non-primitive-unmarshaller ]
-        [ struct-unmarshaller ] if
+        [ drop [ ] ]
-    ] if* ;
+    } 1|| ;
 
 : out-arg-unmarshaller ( type -- quot )
     dup pointer-to-non-const-primitive?

extra/combinators/tuple/tuple-docs.factor

@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: assocs classes help.markup help.syntax kernel math
+quotations strings ;
+IN: combinators.tuple
+
+HELP: 2make-tuple
+{ $values
+    { "x" object } { "y" object } { "class" class } { "assoc" assoc }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: 3make-tuple
+{ $values
+    { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: make-tuple
+{ $values
+    { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: nmake-tuple
+{ $values
+    { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
+
+{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
+
+ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+{ $subsection make-tuple }
+{ $subsection 2make-tuple }
+{ $subsection 3make-tuple }
+{ $subsection nmake-tuple }
+;
+
+ABOUT: "combinators.tuple"

extra/combinators/tuple/tuple.factor

@@ -0,0 +1,29 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+    slot name>> assoc at [
+        slot initial>> :> initial
+        { n ndrop initial } >quotation
+    ] unless* ;
+
+PRIVATE>
+
+MACRO:: nmake-tuple ( class assoc n -- )
+    class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
+    class <wrapper> :> \class
+    { quots n ncleave \class boa } >quotation ;
+    
+: make-tuple ( x class assoc -- tuple )
+    1 nmake-tuple ; inline
+
+: 2make-tuple ( x y class assoc -- tuple )
+    2 nmake-tuple ; inline
+
+: 3make-tuple ( x y z class assoc -- tuple )
+    3 nmake-tuple ; inline
+

extra/constructors/constructors-tests.factor

@@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj )
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct2 ( a b -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct3 ( a b c -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct4 ( a b c d -- obj )
-    initialize-ct3
     [ 1 + ] change-a ;
 
 [ 1001 ] [ 1000 <ct1> a>> ] unit-test
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a  -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
-    dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
-    10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
-    5 >>hp
-    10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test

extra/constructors/constructors.factor

@@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot )
     class def define-initializer
     class effect in>> '[ _ _ slots>constructor ] ;
 
-:: define-constructor ( constructor-word class effect def -- )
+:: define-constructor ( constructor-word class effect def reverse? -- )
-    constructor-word class effect def (define-constructor)
-    class lookup-initializer
-    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
     constructor-word class effect def (define-constructor)
     class superclasses [ lookup-initializer ] map sift
     reverse? [ reverse ] when
@@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot )
 : parse-constructor ( -- class word effect def )
     scan-constructor complete-effect parse-definition ;
 
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
+SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
 
 "initializers" create-vocab drop