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

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

@@ -1,56 +1 @@
-USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis compiler.cfg.debugger
-cpu.architecture tools.test kernel ;
 IN: compiler.cfg.alias-analysis.tests
-
-[ ] [
-    {
-        T{ ##peek f V int-regs 2 D 1 f }
-        T{ ##box-alien f V int-regs 1 V int-regs 2 }
-        T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[ ] [
-    {
-        T{ ##load-reference f V int-regs 1 "hello" }
-        T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##copy f V int-regs 3 V int-regs 2 f }
-        T{ ##copy f V int-regs 4 V int-regs 1 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-        T{ ##replace f V int-regs 2 D 1 f }
-        T{ ##peek f V int-regs 3 D 1 f }
-        T{ ##peek f V int-regs 4 D 0 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    } alias-analysis
-] unit-test

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

@@ -1,15 +1,13 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 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.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.alias-analysis
 
-! Alias analysis -- assumes compiler.cfg.height has already run.
+! We try to eliminate redundant slot operations using some simple heuristics.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
 ! 
 ! All heap-allocated objects which are loaded from the stack, or
 ! other object slots are pessimistically assumed to belong to
@@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis
 !
 ! Freshly-allocated objects get their own alias class.
 !
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-! 
 ! Simple pseudo-C example showing load elimination:
 ! 
 ! int *x, *y, z: inputs
@@ -68,15 +63,14 @@ IN: compiler.cfg.alias-analysis
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
-: check ( obj -- obj )
+ERROR: vreg-ac-not-set vreg ;
-    [ "BUG: static type error detected" throw ] unless* ; inline
+
- 
 : vreg>ac ( vreg -- ac )
     #! Only vregs produced by ##allot, ##peek and ##slot can
     #! ever be used as valid inputs to ##slot and ##set-slot,
     #! so we assert this fact by not giving alias classes to
     #! other vregs.
-    vregs>acs get at check ;
+    vregs>acs get ?at [ vreg-ac-not-set ] unless ;
 
 ! Map alias classes -> sequence of vregs
 SYMBOL: acs>vregs
@@ -122,8 +116,10 @@ SYMBOL: histories
     #! value.
     over [ live-slots get at at ] [ 2drop f ] if ;
 
+ERROR: vreg-has-no-slots vreg ;
+
 : load-constant-slot ( value slot# vreg -- )
-    live-slots get at check set-at ;
+    live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
 
 : load-slot ( value slot#/f vreg -- )
     over [ load-constant-slot ] [ 3drop ] if ;
@@ -189,67 +185,49 @@ SYMBOL: constants
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: ##peek insn-slot# loc>> n>> ;
-M: ##replace insn-slot# loc>> n>> ;
 M: ##slot insn-slot# slot>> constant ;
 M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 
-M: ##peek insn-object loc>> class ;
-M: ##replace insn-object loc>> class ;
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 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 ( -- )
+: init-alias-analysis ( live-in -- )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
     H{ } clone live-slots set
     H{ } clone constants set
     H{ } clone copies set
-
+    
     0 ac-counter set
     next-ac heap-ac set
 
-    ds-loc next-ac set-ac
+    [ set-heap-ac ] each ;
-    rs-loc next-ac set-ac ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: ##load-reference analyze-aliases*
+M: ##flushable analyze-aliases*
     dup dst>> set-heap-ac ;
 
-M: ##alien-global analyze-aliases*
+M: ##allocation analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##allot analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-float analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-alien analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
     dup dst>> set-new-ac ;
 
 M: ##read analyze-aliases*
-    dup dst>> set-heap-ac
+    call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
-        2nip f \ ##copy boa analyze-aliases* nip
+        2nip \ ##copy new-insn analyze-aliases* nip
     ] [
         drop remember-slot
     ] if ;
@@ -292,15 +270,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
         ] unless
     ] when ;
 
-M: ##replace eliminate-dead-stores*
-    #! Writes to above the top of the stack can be pruned also.
-    #! This is sound since any such writes are not observable
-    #! after the basic block, and any reads of those locations
-    #! will have been converted to copies by analyze-slot,
-    #! and the final stack height of the basic block is set at
-    #! the beginning by compiler.cfg.stack.
-    dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
-
 M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
 
 M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
@@ -310,8 +279,10 @@ M: insn eliminate-dead-stores* ;
 : eliminate-dead-stores ( insns -- insns' )
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
-: alias-analysis ( insns -- insns' )
+: 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 ;

basis/compiler/cfg/builder/builder.factor

@@ -81,30 +81,35 @@ GENERIC: emit-node ( node -- next )
     basic-block get successors>> push
     stop-iterating ;
 
-: emit-call ( word -- next )
+: emit-call ( word height -- next )
     {
-        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
+        { [ terminate-call? ] [ ##call stop-iterating ] }
         { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
-        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
+        { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
-        [ ##epilogue ##jump stop-iterating ]
+        [ drop ##epilogue ##jump stop-iterating ]
     } cond ;
 
 ! #recursive
-: compile-recursive ( node -- next )
+: recursive-height ( #recursive -- n )
-    [ label>> id>> emit-call ]
+    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-recursive ( #recursive -- next )
+    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
     basic-block get swap loops get set-at ;
 
-: compile-loop ( node -- next )
+: emit-loop ( node -- next )
     ##loop-entry
+    ##branch
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
 
 M: #recursive emit-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+    dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 
 ! #if
 : emit-branch ( obj -- final-bb )
@@ -154,65 +159,16 @@ M: #if emit-node
     } cond iterate-next ;
 
 ! #dispatch
-: trivial-dispatch-branch? ( nodes -- ? )
-    dup length 1 = [
-        first dup #call? [
-            word>> "intrinsic" word-prop not
-        ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: dispatch-branch ( nodes word -- label )
-    over trivial-dispatch-branch? [
-        drop first word>>
-    ] [
-        gensym [
-            [
-                V{ } clone node-stack set
-                ##prologue
-                begin-basic-block
-                emit-nodes
-                basic-block get [
-                    ##epilogue
-                    ##return
-                    end-basic-block
-                ] when
-            ] with-cfg-builder
-        ] keep
-    ] if ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        current-word get dispatch-branch
-        ##dispatch-label
-    ] each ;
-
-: emit-dispatch ( node -- )
-    ##epilogue
-    ds-pop ^^offset>slot i 0 ##dispatch
-    dispatch-branches ;
-
-: <dispatch-block> ( -- word )
-    gensym dup t "inlined-block" set-word-prop ;
-
 M: #dispatch emit-node
-    tail-call? [
+    ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
-        emit-dispatch stop-iterating
-    ] [
-        current-word get <dispatch-block> [
-            [
-                begin-word
-                emit-dispatch
-            ] with-cfg-builder
-        ] keep emit-call
-    ] if ;
 
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node

basis/compiler/cfg/cfg.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors namespaces ;
+USING: kernel arrays vectors accessors
+namespaces make fry sequences ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
@@ -10,18 +11,27 @@ number
 { successors vector }
 { predecessors vector } ;
 
-: <basic-block> ( -- basic-block )
+M: basic-block hashcode* nip id>> ;
+
+: <basic-block> ( -- bb )
     basic-block new
         V{ } clone >>instructions
         V{ } clone >>successors
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
-TUPLE: cfg { entry basic-block } word label ;
+: add-instructions ( bb quot -- )
+    [ instructions>> building ] dip '[
+        building get pop
+        _ dip
+        building get push
+    ] with-variable ; inline
 
-C: <cfg> cfg
+TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
 
-TUPLE: mr { instructions array } word label spill-counts ;
+: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+
+TUPLE: mr { instructions array } word label ;
 
 : <mr> ( instructions word label -- mr )
     mr new

basis/compiler/cfg/checker/authors.txt

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

basis/compiler/cfg/checker/checker.factor

@@ -0,0 +1,58 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+combinators.short-circuit accessors math sequences sets assocs ;
+IN: compiler.cfg.checker
+
+ERROR: last-insn-not-a-jump insn ;
+
+: check-last-instruction ( bb -- )
+    last dup {
+        [ ##branch? ]
+        [ ##dispatch? ]
+        [ ##conditional-branch? ]
+        [ ##compare-imm-branch? ]
+        [ ##return? ]
+        [ ##callback-return? ]
+        [ ##jump? ]
+        [ ##call? ]
+    } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
+
+ERROR: bad-loop-entry ;
+
+: check-loop-entry ( bb -- )
+    dup length 2 >= [
+        2 head* [ ##loop-entry? ] any?
+        [ bad-loop-entry ] when
+    ] [ drop ] if ;
+
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+    dup successors>> [ predecessors>> memq? ] with all?
+    [ bad-successors ] unless ;
+
+: check-basic-block ( bb -- )
+    [ instructions>> check-last-instruction ]
+    [ instructions>> check-loop-entry ]
+    [ check-successors ]
+    tri ;
+
+ERROR: bad-live-in ;
+
+ERROR: undefined-values uses defs ;
+
+: check-mr ( mr -- )
+    ! Check that every used register has a definition
+    instructions>>
+    [ [ uses-vregs ] map concat ]
+    [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+    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 ]
+    tri ;

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

@@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
-    dup copies get at swap or ;
+    [ copies get at ] keep or ;
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

basis/compiler/cfg/dce/authors.txt

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

basis/compiler/cfg/dce/dce.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use
+compiler.cfg.rpo ;
+IN: compiler.cfg.dce
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+: init-dead-code ( -- )
+    H{ } clone liveness-graph set
+    H{ } clone live-vregs set ;
+
+GENERIC: update-liveness-graph ( insn -- )
+
+M: ##flushable update-liveness-graph
+    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+: record-live ( vregs -- )
+    [
+        dup live-vregs get key? [ drop ] [
+            [ live-vregs get conjoin ]
+            [ liveness-graph get at record-live ]
+            bi
+        ] if
+    ] each ;
+
+M: insn update-liveness-graph uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( cfg -- cfg' )
+    init-dead-code
+    [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+    [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
+    [ ]
+    tri ;

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

@@ -1,9 +0,0 @@
-USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture tools.test ;
-IN: compiler.cfg.dead-code.tests
-
-[ { } ] [
-    { T{ ##load-immediate f V int-regs 134 16 } }
-    eliminate-dead-code
-] unit-test

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

@@ -1,61 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.def-use ;
-IN: compiler.cfg.dead-code
-
-! Dead code elimination -- assumes compiler.cfg.alias-analysis
-! has already run.
-
-! Maps vregs to sequences of vregs
-SYMBOL: liveness-graph
-
-! vregs which participate in side effects and thus are always live
-SYMBOL: live-vregs
-
-! mapping vregs to stack locations
-SYMBOL: vregs>locs
-
-: init-dead-code ( -- )
-    H{ } clone liveness-graph set
-    H{ } clone live-vregs set
-    H{ } clone vregs>locs set ;
-
-GENERIC: compute-liveness ( insn -- )
-
-M: ##flushable compute-liveness
-    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
-
-M: ##peek compute-liveness
-    [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
-    [ call-next-method ]
-    bi ;
-
-: live-replace? ( ##replace -- ? )
-    [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
-
-M: ##replace compute-liveness
-    dup live-replace? [ call-next-method ] [ drop ] if ;
-
-: record-live ( vregs -- )
-    [
-        dup live-vregs get key? [ drop ] [
-            [ live-vregs get conjoin ]
-            [ liveness-graph get at record-live ]
-            bi
-        ] if
-    ] each ;
-
-M: insn compute-liveness uses-vregs record-live ;
-
-GENERIC: live-insn? ( insn -- ? )
-
-M: ##flushable live-insn? dst>> live-vregs get key? ;
-
-M: ##replace live-insn? live-replace? ;
-
-M: insn live-insn? drop t ;
-
-: eliminate-dead-code ( insns -- insns' )
-    init-dead-code
-    [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;

basis/compiler/cfg/dead-code/summary.txt

@@ -1 +0,0 @@
-Dead-code elimination

basis/compiler/cfg/debugger/debugger.factor

@@ -7,7 +7,8 @@ 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.optimizer ;
+compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.mr ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -18,20 +19,14 @@ M: callable test-cfg
 M: word test-cfg
     [ build-tree optimize-tree ] keep build-cfg ;
 
-SYMBOL: allocate-registers?
-
 : test-mr ( quot -- mrs )
     test-cfg [
         optimize-cfg
         build-mr
-        convert-two-operand
-        allocate-registers? get
-        [ linear-scan build-stack-frame ] when
     ] map ;
 
 : insn. ( insn -- )
-    tuple>array allocate-registers? get [ but-last ] unless
+    tuple>array [ pprint bl ] each nl ;
-    [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [

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

@@ -1,28 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )
+GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
 M: ##flushable defs-vregs dst>> 1array ;
-M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp defs-vregs dst>> 1array ;
-M: ##unary/temp defs-vregs dst/tmp-vregs ;
+M: ##allot defs-vregs dst>> 1array ;
-M: ##allot defs-vregs dst/tmp-vregs ;
+M: ##slot defs-vregs dst>> 1array ;
-M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs dst/tmp-vregs ;
 M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst/tmp-vregs ;
+M: ##string-nth defs-vregs dst>> 1array ;
-M: ##set-string-nth-fast defs-vregs temp>> 1array ;
+M: ##compare defs-vregs dst>> 1array ;
-M: ##compare defs-vregs dst/tmp-vregs ;
+M: ##compare-imm defs-vregs dst>> 1array ;
-M: ##compare-imm defs-vregs dst/tmp-vregs ;
+M: ##compare-float defs-vregs dst>> 1array ;
-M: ##compare-float defs-vregs dst/tmp-vregs ;
-M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
+M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp temp-vregs temp>> 1array ;
+M: ##allot temp-vregs temp>> 1array ;
+M: ##dispatch temp-vregs temp>> 1array ;
+M: ##slot temp-vregs temp>> 1array ;
+M: ##set-slot temp-vregs temp>> 1array ;
+M: ##string-nth temp-vregs temp>> 1array ;
+M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##compare temp-vregs temp>> 1array ;
+M: ##compare-imm temp-vregs temp>> 1array ;
+M: ##compare-float temp-vregs temp>> 1array ;
+M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch temp-vregs temp>> 1array ;
+M: insn temp-vregs drop f ;
+
 M: ##unary uses-vregs src>> 1array ;
 M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##binary-imm uses-vregs src1>> 1array ;
@@ -39,10 +50,14 @@ M: ##dispatch uses-vregs src>> 1array ;
 M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##phi uses-vregs inputs>> ;
+M: ##gc uses-vregs live-in>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
+! Instructions that use vregs
 UNION: vreg-insn
 ##flushable
 ##write-barrier
@@ -51,5 +66,8 @@ UNION: vreg-insn
 ##fixnum-overflow
 ##conditional-branch
 ##compare-imm-branch
+##phi
+##gc
 _conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;

basis/compiler/cfg/dominance/authors.txt

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

basis/compiler/cfg/dominance/dominance.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.rpo
+compiler.cfg.stack-analysis fry kernel math.order namespaces
+sequences ;
+IN: compiler.cfg.dominance
+
+! Reference:
+
+! A Simple, Fast Dominance Algorithm
+! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
+! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+
+SYMBOL: idoms
+
+: idom ( bb -- bb' ) idoms get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+    2dup [ number>> ] compare {
+        { +lt+ [ [ idom ] dip intersect ] }
+        { +gt+ [ idom intersect ] }
+        [ 2drop ]
+    } case ;
+
+: compute-idom ( bb -- idom )
+    predecessors>> [ idom ] map sift
+    [ ] [ intersect ] map-reduce ;
+
+: iterate ( rpo -- changed? )
+    [ [ compute-idom ] keep set-idom ] map [ ] any? ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- cfg )
+    H{ } clone idoms set
+    dup reverse-post-order
+    unclip dup set-idom drop '[ _ iterate ] loop ;

basis/compiler/cfg/gc-checks/authors.txt

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

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs
+cpu.architecture compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.instructions ;
+IN: compiler.cfg.gc-checks
+
+: gc? ( bb -- ? )
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-in keys [ reg-class>> int-regs eq? ] filter ;
+
+: insert-gc-check ( basic-block -- )
+    dup gc? [
+        dup
+        [ swap object-pointer-regs \ ##gc new-insn prefix ]
+        change-instructions drop
+    ] [ drop ] if ;
+
+: insert-gc-checks ( cfg -- cfg' )
+    dup [ insert-gc-check ] each-basic-block ;

basis/compiler/cfg/hats/hats.factor

@@ -73,3 +73,5 @@ IN: compiler.cfg.hats
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
+
+: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline

basis/compiler/cfg/height/height.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
@@ -42,10 +43,13 @@ M: ##replace normalize-height* normalize-peek/replace ;
 
 M: insn normalize-height* ;
 
-: normalize-height ( insns -- insns' )
+: height-step ( insns -- insns' )
     0 ds-height set
     0 rs-height set
     [ [ compute-heights ] each ]
     [ [ [ normalize-height* ] map sift ] with-scope ] bi
-    ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
+    ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
-    rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
+    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+
+: normalize-height ( cfg -- cfg' )
+    [ drop ] [ height-step ] local-optimization ;

basis/compiler/cfg/instructions/instructions.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra alien byte-arrays
@@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
+: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+
 ! Virtual CPU instructions, used by CFG and machine IRs
 TUPLE: insn ;
 
@@ -44,8 +46,8 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
 M: f ##load-literal drop \ f tag-number ##load-immediate ;
 M: object ##load-literal ##load-reference ;
 
-INSN: ##peek < ##read { loc loc } ;
+INSN: ##peek < ##flushable { loc loc } ;
-INSN: ##replace < ##write { loc loc } ;
+INSN: ##replace < ##effect { loc loc } ;
 INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
@@ -57,13 +59,12 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
 
 ! Jump tables
-INSN: ##dispatch src temp offset ;
+INSN: ##dispatch src temp ;
-INSN: ##dispatch-label label ;
 
 ! Slot access
 INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@@ -160,9 +161,12 @@ INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
 INSN: ##allot < ##flushable size class { temp vreg } ;
+
+UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+
 INSN: ##write-barrier < ##effect card# table ;
 
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
 
 ! FFI
 INSN: ##alien-invoke params ;
@@ -178,6 +182,8 @@ INSN: ##branch ;
 
 INSN: ##loop-entry ;
 
+INSN: ##phi < ##pure inputs ;
+
 ! Condition codes
 SYMBOL: cc<
 SYMBOL: cc<=
@@ -217,16 +223,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
+INSN: ##gc live-in ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
 INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-INSN: _gc ;
-
 INSN: _branch label ;
 
+INSN: _dispatch src temp ;
+INSN: _dispatch-label label ;
+
 TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 
 INSN: _compare-branch < _conditional-branch ;

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
     "insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
-    boa-effect in>> but-last f <effect> ;
+    boa-effect in>> 2 head* f <effect> ;
 
 SYNTAX: INSN:
-    parse-tuple-definition "regs" suffix
+    parse-tuple-definition { "regs" "insn#" } append
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
+    [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
     3tri ;

basis/compiler/cfg/iterator/iterator.factor

@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        [ t ] [
+        [ t ] [ (tail-call?) ] if-empty
-            [ (tail-call?) ]
-            [ first #terminate? not ]
-            bi and
-        ] if-empty
     ] all? ;
+
+: terminate-call? ( -- ? )
+    node-stack get last
+    rest-slice [ f ] [ first #terminate? ] if-empty ;

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

@@ -13,13 +13,13 @@ IN: compiler.cfg.linear-scan.assignment
 ! but since we never have too many machine registers (around 30
 ! at most) and we probably won't have that many live at any one
 ! time anyway, it is not a problem to check each element.
-SYMBOL: active-intervals
+TUPLE: active-intervals seq ;
 
 : add-active ( live-interval -- )
-    active-intervals get push ;
+    active-intervals get seq>> push ;
 
 : lookup-register ( vreg -- reg )
-    active-intervals get [ vreg>> = ] with find nip reg>> ;
+    active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals
 
 : expire-old-intervals ( n -- )
     active-intervals get
-    swap '[ end>> _ = ] partition
+    [ swap '[ end>> _ = ] partition ] change-seq drop
-    active-intervals set
     [ insert-spill ] each ;
 
 : insert-reload ( live-interval -- )
@@ -59,29 +58,38 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-GENERIC: (assign-registers) ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
 
-M: vreg-insn (assign-registers)
+: all-vregs ( insn -- vregs )
-    dup
+    [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-    [ defs-vregs ] [ uses-vregs ] bi append
+
-    active-intervals get swap '[ vreg>> _ member? ] filter
+M: vreg-insn assign-registers-in-insn
+    active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
-M: insn (assign-registers) drop ;
+M: insn assign-registers-in-insn drop ;
+
+: <active-intervals> ( -- obj )
+    V{ } clone active-intervals boa ;
 
 : init-assignment ( live-intervals -- )
-    V{ } clone active-intervals set
+    <active-intervals> active-intervals set
     <min-heap> unhandled-intervals set
     init-unhandled ;
 
-: assign-registers ( insns live-intervals -- insns' )
+: assign-registers-in-block ( bb -- )
     [
-        init-assignment
         [
-            [ activate-new-intervals ]
+            [
-            [ drop [ (assign-registers) ] [ , ] bi ]
+                [ insn#>> activate-new-intervals ]
-            [ expire-old-intervals ]
+                [ [ assign-registers-in-insn ] [ , ] bi ]
-            tri
+                [ insn#>> expire-old-intervals ]
-        ] each-index
+                tri
-    ] { } make ;
+            ] each
+        ] V{ } make
+    ] change-instructions drop ;
+
+: assign-registers ( rpo live-intervals -- )
+    init-assignment
+    [ assign-registers-in-block ] each ;

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

@@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
 math.order grouping
 cpu.architecture
+compiler.cfg
+compiler.cfg.optimizer
 compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.linear-scan
@@ -264,18 +266,27 @@ SYMBOL: max-uses
 
 USING: math.private compiler.cfg.debugger ;
 
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+[ ] [
+    [ float+ float>fixnum 3 fixnum*fast ]
+    test-cfg first optimize-cfg linear-scan drop
+] unit-test
 
 [ f ] [
-    T{ ##allot
+    T{ basic-block
-        f
+       { instructions
-        T{ vreg f int-regs 1 }
+         V{
-        40
+             T{ ##allot
-        array
+                f
-        T{ vreg f int-regs 2 }
+                T{ vreg f int-regs 1 }
-        f
+                40
-    } clone
+                array
-    1array (linear-scan) first regs>> values all-equal?
+                T{ vreg f int-regs 2 }
+                f
+             }
+         }
+       }
+    } clone [ [ clone ] map ] change-instructions
+    dup 1array (linear-scan) instructions>> first regs>> values all-equal?
 ] unit-test
 
 [ 0 1 ] [

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

@@ -1,9 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make
 cpu.architecture
 compiler.cfg
+compiler.cfg.rpo
 compiler.cfg.instructions
+compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.assignment ;
@@ -23,16 +25,13 @@ 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) ( insns -- insns' )
+: (linear-scan) ( rpo -- )
+    dup number-instructions
     dup compute-live-intervals
     machine-registers allocate-registers assign-registers ;
 
-: linear-scan ( mr -- mr' )
+: linear-scan ( cfg -- cfg' )
     [
-        [
+        dup reverse-post-order (linear-scan)
-            [
+        spill-counts get >>spill-counts
-                (linear-scan) %
-                spill-counts get _spill-counts
-            ] { } make
-        ] change-instructions
     ] with-scope ;

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math fry
 compiler.cfg.instructions compiler.cfg.registers
@@ -38,27 +38,29 @@ SYMBOL: live-intervals
         [ [ <live-interval> ] keep ] dip set-at
     ] if ;
 
-GENERIC# compute-live-intervals* 1 ( insn n -- )
+GENERIC: compute-live-intervals* ( insn -- )
 
-M: insn compute-live-intervals* 2drop ;
+M: insn compute-live-intervals* drop ;
 
 M: vreg-insn compute-live-intervals*
+    dup insn#>>
     live-intervals get
     [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
     [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
-    3bi ;
+    [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    3tri ;
 
 : record-copy ( insn -- )
     [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
 
 M: ##copy compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
 M: ##copy-float compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
-: compute-live-intervals ( instructions -- live-intervals )
+: compute-live-intervals ( rpo -- live-intervals )
     H{ } clone [
         live-intervals set
-        [ compute-live-intervals* ] each-index
+        [ instructions>> [ compute-live-intervals* ] each ] each
     ] keep values ;

basis/compiler/cfg/linear-scan/numbering/authors.txt

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

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

@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math sequences ;
+IN: compiler.cfg.linear-scan.numbering
+
+: number-instructions ( rpo -- )
+    [ 0 ] dip [
+        instructions>> [
+            [ (>>insn#) ] [ drop 2 + ] 2bi
+        ] each
+    ] each drop ;

basis/compiler/cfg/linearization/linearization.factor

@@ -1,24 +1,28 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators classes
+combinators assocs
+cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-insns ( basic-block -- )
+: linearize-basic-block ( bb -- )
-    dup instructions>> [ linearize-insn ] with each ; inline
+    [ number>> _label ]
+    [ dup instructions>> [ linearize-insn ] with each ]
+    bi ;
 
 M: insn linearize-insn , drop ;
 
 : useless-branch? ( basic-block successor -- ? )
     #! If our successor immediately follows us in RPO, then we
     #! don't need to branch.
-    [ number>> ] bi@ 1- = ; inline
+    [ number>> ] bi@ 1 - = ; inline
 
 : branch-to-branch? ( successor -- ? )
     #! A branch to a block containing just a jump return is cloned.
@@ -30,7 +34,7 @@ M: insn linearize-insn , drop ;
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+        { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
         [ nip number>> _branch ]
     } cond ;
 
@@ -46,35 +50,31 @@ M: ##branch linearize-insn
     [ drop dup successors>> second useless-branch? ] 2bi
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
 
+: with-regs ( insn quot -- )
+    over regs>> [ call ] dip building get last (>>regs) ; inline
+
 M: ##compare-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
+    [ binary-conditional _compare-branch ] with-regs emit-branch ;
 
 M: ##compare-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
+    [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
 
 M: ##compare-float-branch linearize-insn
-    binary-conditional _compare-float-branch emit-branch ;
+    [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
-: gc? ( bb -- ? )
+M: ##dispatch linearize-insn
-    instructions>> [
+    swap
-        class {
+    [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
-            ##allot
+    [ successors>> [ number>> _dispatch-label ] each ]
-            ##integer>bignum
+    bi* ;
-            ##box-float
-            ##box-alien
-        } memq?
-    ] any? ;
 
-: linearize-basic-block ( bb -- )
+: linearize-basic-blocks ( cfg -- insns )
-    [ number>> _label ]
+    [
-    [ gc? [ _gc ] when ]
+        [ [ linearize-basic-block ] each-basic-block ]
-    [ linearize-insns ]
+        [ spill-counts>> _spill-counts ]
-    tri ;
+        bi
+    ] { } make ;
 
-: linearize-basic-blocks ( rpo -- insns )
+: flatten-cfg ( cfg -- mr )
-    [ [ linearize-basic-block ] each ] { } make ;
+    [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
-
+    <mr> ;
-: build-mr ( cfg -- mr )
-    [ entry>> reverse-post-order linearize-basic-blocks ]
-    [ word>> ] [ label>> ]
-    tri <mr> ;

basis/compiler/cfg/liveness/authors.txt

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

basis/compiler/cfg/liveness/liveness.factor

@@ -0,0 +1,78 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo ;
+IN: compiler.cfg.liveness
+
+! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-ins
+
+: live-in ( basic-block -- set ) live-ins get at ;
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in conrrespondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set )
+    [ predecessors>> index ] keep phi-live-ins get at
+    dup [ nth ] [ 2drop f ] if ;
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-outs
+
+: 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 ] [ [ inputs>> ] map flip [ unique ] map ] 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

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

basis/compiler/cfg/local/local.factor

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

basis/compiler/cfg/mr/authors.txt

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

basis/compiler/cfg/mr/mr.factor

@@ -0,0 +1,14 @@
+! 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.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
+    build-stack-frame ;

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

@@ -0,0 +1,34 @@
+USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+sequences.private math sbufs math.private slots.private strings ;
+IN: compiler.cfg.optimizer.tests
+
+! Miscellaneous tests
+
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+    test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
+{
+    [ 1array ]
+    [ 1 2 ? ]
+    [ { array } declare [ ] map ]
+    [ { array } declare dup 1 slot [ 1 slot ] when ]
+    [ [ dup more? ] [ dup ] produce ]
+    [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+    [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+    [
+        { fixnum sbuf } declare 2dup 3 slot fixnum> [
+            over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+        ] [ ] if
+    ]
+    [ [ 2 fixnum* ] when 3 ]
+    [ [ 2 fixnum+ ] when 3 ]
+    [ [ 2 fixnum- ] when 3 ]
+    [ 10000 [ ] times ]
+} [
+    [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+] each

basis/compiler/cfg/optimizer/optimizer.factor

@@ -1,29 +1,30 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.cfg.rpo
+USING: kernel sequences accessors combinators namespaces
-compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
 compiler.cfg.height
+compiler.cfg.stack-analysis
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
-compiler.cfg.dead-code
+compiler.cfg.dce
-compiler.cfg.write-barrier ;
+compiler.cfg.write-barrier
+compiler.cfg.liveness
+compiler.cfg.rpo
+compiler.cfg.phi-elimination ;
 IN: compiler.cfg.optimizer
 
-: trivial? ( insns -- ? )
-    dup length 2 = [ first ##call? ] [ drop f ] if ;
-
 : optimize-cfg ( cfg -- cfg' )
-    compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
     [
-        dup trivial? [
+        compute-predecessors
-            normalize-height
+        delete-useless-blocks
-            alias-analysis
+        delete-useless-conditionals
-            value-numbering
+        normalize-height
-            eliminate-dead-code
+        stack-analysis
-            eliminate-write-barriers
+        compute-liveness
-        ] unless
+        alias-analysis
-    ] change-basic-blocks ;
+        value-numbering
+        eliminate-dead-code
+        eliminate-write-barriers
+        eliminate-phis
+    ] with-scope ;

basis/compiler/cfg/phi-elimination/authors.txt

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

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

@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo fry kernel sequences ;
+IN: compiler.cfg.phi-elimination
+
+: insert-copy ( predecessor input output -- )
+    '[ _ _ swap ##copy ] add-instructions ;
+
+: eliminate-phi ( bb ##phi -- )
+    [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
+    '[ _ insert-copy ] 2each ;
+
+: eliminate-phi-step ( bb -- )
+    dup [
+        [ ##phi? ] partition
+        [ [ eliminate-phi ] with each ] dip
+    ] change-instructions drop ;
+
+: eliminate-phis ( cfg -- cfg' )
+    dup [ eliminate-phi-step ] each-basic-block ;

basis/compiler/cfg/predecessors/predecessors.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 accessors sequences compiler.cfg.rpo ;
 IN: compiler.cfg.predecessors
 
-: (compute-predecessors) ( bb -- )
+: predecessors-step ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
 : compute-predecessors ( cfg -- cfg' )
-    dup [ (compute-predecessors) ] each-basic-block ;
+    dup [ predecessors-step ] each-basic-block ;

basis/compiler/cfg/rpo/rpo.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make math sequences sets
 assocs fry compiler.cfg compiler.cfg.instructions ;
@@ -7,29 +7,29 @@ IN: compiler.cfg.rpo
 SYMBOL: visited
 
 : post-order-traversal ( bb -- )
-    dup id>> visited get key? [ drop ] [
+    dup visited get key? [ drop ] [
-        dup id>> visited get conjoin
+        dup visited get conjoin
         [
             successors>> <reversed>
             [ post-order-traversal ] each
         ] [ , ] bi
     ] if ;
 
-: post-order ( bb -- blocks )
-    [ post-order-traversal ] { } make ;
-
 : number-blocks ( blocks -- )
-    [ >>number drop ] each-index ;
+    dup length iota <reversed>
+    [ >>number drop ] 2each ;
 
-: reverse-post-order ( bb -- blocks )
+: post-order ( cfg -- blocks )
-    H{ } clone visited [
+    dup post-order>> [ ] [
-        post-order <reversed> dup number-blocks
+        [
-    ] with-variable ; inline
+            H{ } clone visited set
+            dup entry>> post-order-traversal
+        ] { } make dup number-blocks
+        >>post-order post-order>>
+    ] ?if ;
+
+: reverse-post-order ( cfg -- blocks )
+    post-order <reversed> ; inline
 
 : each-basic-block ( cfg quot -- )
-    [ entry>> reverse-post-order ] dip each ; inline
+    [ reverse-post-order ] dip each ; inline
-
-: change-basic-blocks ( cfg quot -- cfg' )
-    [ '[ _ change-instructions drop ] each-basic-block ]
-    [ drop ]
-    2bi ; inline

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

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

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

@@ -0,0 +1,113 @@
+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.height compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+sets ;
+IN: compiler.cfg.stack-analysis.tests
+
+! Fundamental invariant: a basic block should not load or store a value more than once
+: check-for-redundant-ops ( cfg -- )
+    [
+        instructions>>
+        [
+            [ ##peek? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant peeks" throw ] unless
+        ] [
+            [ ##replace? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant replaces" throw ] unless
+        ] bi
+    ] each-basic-block ;
+
+: test-stack-analysis ( quot -- cfg )
+    dup cfg? [ test-cfg first ] unless
+    compute-predecessors
+    delete-useless-blocks
+    delete-useless-conditionals
+    normalize-height
+    stack-analysis
+    dup check-cfg
+    dup check-for-redundant-ops ;
+
+: 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
+[ 1 t ] [
+    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
+    [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+] unit-test

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

@@ -0,0 +1,295 @@
+! 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 compiler.cfg.copy-prop compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.hats compiler.cfg ;
+IN: compiler.cfg.stack-analysis
+
+! Convert stack operations to register operations
+
+! If 'poisoned' is set, disregard height information. This is set if we don't have
+! height change information for an instruction.
+TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height 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 ;
+
+GENERIC: height-for ( loc -- n )
+
+M: ds-loc height-for drop state get ds-height>> ;
+M: rs-loc height-for drop state get rs-height>> ;
+
+: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
+M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
+
+GENERIC: untranslate-loc ( loc -- loc' )
+
+M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
+M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+
+: redundant-replace? ( vreg loc -- ? )
+    dup untranslate-loc n>> 0 <
+    [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
+
+: save-changed-locs ( state -- )
+    [ changed-locs>> ] [ locs>vregs>> ] bi '[
+        _ at swap 2dup redundant-replace?
+        [ 2drop ] [ untranslate-loc ##replace ] if
+    ] assoc-each ;
+
+: clear-state ( state -- )
+    [ locs>vregs>> clear-assoc ]
+    [ actual-locs>vregs>> clear-assoc ]
+    [ changed-locs>> clear-assoc ]
+    tri ;
+
+ERROR: poisoned-state state ;
+
+: sync-state ( -- )
+    state get {
+        [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+        [ save-changed-locs ]
+        [ clear-state ]
+    } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+    ##flushable
+    ##effect ;
+
+M: neutral-insn visit , ;
+
+UNION: sync-if-back-edge
+    ##branch
+    ##conditional-branch
+    ##compare-imm-branch
+    ##dispatch
+    ##loop-entry ;
+
+SYMBOL: local-only?
+
+t local-only? set-global
+
+: back-edge? ( from to -- ? )
+    [ number>> ] bi@ > ;
+
+: sync-state? ( -- ? )
+    basic-block get successors>>
+    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
+    local-only? get or ;
+
+M: sync-if-back-edge visit
+    sync-state? [ sync-state ] when , ;
+
+: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
+
+M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
+
+: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
+
+M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
+
+: eliminate-peek ( dst src -- )
+    ! the requested stack location is already in 'src'
+    [ ##copy ] [ swap copies get set-at ] 2bi ;
+
+M: ##peek visit
+    dup
+    [ dst>> ] [ loc>> translate-loc ] bi
+    dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+
+M: ##replace visit
+    [ src>> resolve ] [ loc>> translate-loc ] bi
+    record-replace ;
+
+M: ##copy visit
+    [ call-next-method ] [ record-copy ] bi ;
+
+M: ##call visit
+    [ call-next-method ] [ height>> adjust-d ] bi ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+    ##jump
+    ##return
+    ##callback-return
+    ##fixnum-mul-tail
+    ##fixnum-add-tail
+    ##fixnum-sub-tail ;
+
+M: poison-insn visit call-next-method poison-state ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+    poison-insn
+    ##stack-frame
+    ##call
+    ##prologue
+    ##epilogue
+    ##fixnum-mul
+    ##fixnum-add
+    ##fixnum-sub
+    ##alien-invoke
+    ##alien-indirect ;
+
+M: kill-vreg-insn visit sync-state , ;
+
+: visit-alien-node ( node -- )
+    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+M: ##alien-invoke visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-indirect visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-callback visit , ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
+
+ERROR: must-equal-failed seq ;
+
+: must-equal ( seq -- elt )
+    dup all-equal? [ first ] [ must-equal-failed ] if ;
+
+: merge-heights ( state predecessors states -- state )
+    nip
+    [ [ ds-height>> ] map must-equal >>ds-height ]
+    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+
+: insert-peek ( predecessor loc -- vreg )
+    ! XXX critical edges
+    '[ _ ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors locs>vregs loc -- vreg )
+    ! Insert a ##phi in the current block where the input
+    ! is the vreg storing loc from each predecessor block
+    [ '[ [ _ ] dip at ] map ] keep
+    '[ [ ] [ _ insert-peek ] ?if ] 2map
+    dup all-equal? [ first ] [ ^^phi ] if ;
+
+: (merge-locs) ( predecessors assocs -- assoc )
+    dup [ keys ] map concat prune
+    [ [ 2nip ] [ merge-loc ] 3bi ] with with
+    H{ } map>assoc ;
+
+: merge-locs ( state predecessors states -- state )
+    [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+
+: merge-loc' ( locs>vregs loc -- vreg )
+    ! Insert a ##phi in the current block where the input
+    ! is the vreg storing loc from each predecessor block
+    '[ [ _ ] dip at ] map
+    dup all-equal? [ first ] [ drop f ] if ;
+
+: merge-actual-locs ( state predecessors states -- state )
+    nip
+    [ actual-locs>vregs>> ] map
+    dup [ keys ] map concat prune
+    [ [ nip ] [ merge-loc' ] 2bi ] with
+    H{ } map>assoc
+    [ nip ] assoc-filter
+    >>actual-locs>vregs ;
+
+: merge-changed-locs ( state predecessors states -- state )
+    nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+
+ERROR: cannot-merge-poisoned states ;
+
+: multiple-predecessors ( bb states -- state )
+    dup [ not ] any? [
+        [ <state> ] 2dip
+        sift merge-heights
+    ] [
+        dup [ poisoned?>> ] any? [
+            cannot-merge-poisoned
+        ] [
+            [ state new ] 2dip
+            [ predecessors>> ] dip
+            {
+                [ merge-locs ]
+                [ merge-actual-locs ]
+                [ merge-heights ]
+                [ merge-changed-locs ]
+            } 2cleave
+        ] if
+    ] if ;
+
+: merge-states ( bb states -- state )
+    ! If any states are poisoned, save all registers
+    ! to the stack in each branch
+    dup length {
+        { 0 [ initial-state ] }
+        { 1 [ single-predecessor ] }
+        [ drop multiple-predecessors ]
+    } case ;
+
+: block-in-state ( bb -- states )
+    dup predecessors>> state-out get '[ _ at ] map merge-states ;
+
+: set-block-in-state ( state bb -- )
+    [ clone ] dip state-in get set-at ;
+
+: 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
+        [ swap set-block-in-state ] [
+            state [
+                [ instructions>> [ visit ] each ]
+                [ [ state get ] dip set-block-out-state ]
+                [ ]
+                tri
+            ] with-variable
+        ] 2bi
+    ] V{ } make >>instructions drop ;
+
+: stack-analysis ( cfg -- cfg' )
+    [
+        H{ } clone copies set
+        H{ } clone state-in set
+        H{ } clone state-out set
+        dup [ visit-block ] each-basic-block
+    ] with-scope ;

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

@@ -32,8 +32,8 @@ M: insn compute-stack-frame*
         frame-required? on
     ] when ;
 
-\ _gc t frame-required? set-word-prop
 \ _spill t frame-required? set-word-prop
+\ ##gc t frame-required? set-word-prop
 \ ##fixnum-add t frame-required? set-word-prop
 \ ##fixnum-sub t frame-required? set-word-prop
 \ ##fixnum-mul t frame-required? set-word-prop

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

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences compiler.utilities
+USING: accessors arrays kernel sequences make compiler.cfg.instructions
-compiler.cfg.instructions cpu.architecture ;
+compiler.cfg.rpo cpu.architecture ;
 IN: compiler.cfg.two-operand
 
 ! On x86, instructions take the form x = x op y
@@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand
 ! has a LEA instruction which is effectively a three-operand
 ! addition
 
-: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
 
-: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
 
-: convert-two-operand/integer ( insn -- insns )
+: convert-two-operand/integer ( insn -- )
-    [ [ dst>> ] [ src1>> ] bi make-copy ]
+    [ [ dst>> ] [ src1>> ] bi ##copy ]
-    [ dup dst>> >>src1 ]
+    [ dup dst>> >>src1 , ]
-    bi 2array ; inline
+    bi ; inline
 
-: convert-two-operand/float ( insn -- insns )
+: convert-two-operand/float ( insn -- )
-    [ [ dst>> ] [ src1>> ] bi make-copy/float ]
+    [ [ dst>> ] [ src1>> ] bi ##copy-float ]
-    [ dup dst>> >>src1 ]
+    [ dup dst>> >>src1 , ]
-    bi 2array ; inline
+    bi ; inline
 
-GENERIC: convert-two-operand* ( insn -- insns )
+GENERIC: convert-two-operand* ( insn -- )
 
 M: ##not convert-two-operand*
-    [ [ dst>> ] [ src>> ] bi make-copy ]
+    [ [ dst>> ] [ src>> ] bi ##copy ]
-    [ dup dst>> >>src ]
+    [ dup dst>> >>src , ]
-    bi 2array ;
+    bi ;
 
 M: ##sub convert-two-operand* convert-two-operand/integer ;
 M: ##mul convert-two-operand* convert-two-operand/integer ;
@@ -50,11 +50,13 @@ M: ##sub-float convert-two-operand* convert-two-operand/float ;
 M: ##mul-float convert-two-operand* convert-two-operand/float ;
 M: ##div-float convert-two-operand* convert-two-operand/float ;
 
-M: insn convert-two-operand* ;
+M: insn convert-two-operand* , ;
 
-: convert-two-operand ( mr -- mr' )
+: convert-two-operand ( cfg -- cfg' )
-    [
+    two-operand? [
-        two-operand? [
+        dup [
-            [ convert-two-operand* ] map-flat
+            [
-        ] when
+                [ [ convert-two-operand* ] each ] V{ } make
-    ] change-instructions ;
+            ] change-instructions drop
+        ] each-basic-block
+    ] when ;

basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor

@@ -0,0 +1,11 @@
+IN: compiler.cfg.useless-blocks.tests
+USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
+
+{
+    [ [ drop 1 ] when ]
+    [ [ drop 1 ] unless ]
+} [
+    [ [ ] ] dip
+    '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
+] each

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

@@ -1,10 +1,12 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators classes vectors
+USING: kernel accessors sequences combinators combinators.short-circuit
-compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.useless-blocks
 
 : update-predecessor-for-delete ( 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
@@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
     ] change-successors drop ;
 
 : update-successor-for-delete ( bb -- )
-    [ predecessors>> first ]
+    ! We have to replace occurrences of bb with bb's predecessor
-    [ successors>> first predecessors>> ]
+    ! in bb's sucessor's list of predecessors.
-    bi set-first ;
+    dup successors>> first [
+        [
+            2dup eq? [ drop predecessors>> first ] [ nip ] if
+        ] with map
+    ] change-predecessors drop ;
 
 : delete-basic-block ( bb -- )
     [ update-predecessor-for-delete ]
@@ -23,17 +29,17 @@ IN: compiler.cfg.useless-blocks
 
 : delete-basic-block? ( bb -- ? )
     {
-        { [ dup instructions>> length 1 = not ] [ f ] }
+        [ instructions>> length 1 = ]
-        { [ dup predecessors>> length 1 = not ] [ f ] }
+        [ predecessors>> length 1 = ]
-        { [ dup successors>> length 1 = not ] [ f ] }
+        [ successors>> length 1 = ]
-        { [ dup instructions>> first ##branch? not ] [ f ] }
+        [ instructions>> first ##branch? ]
-        [ t ]
+    } 1&& ;
-    } cond nip ;
 
 : delete-useless-blocks ( cfg -- cfg' )
     dup [
         dup delete-basic-block? [ delete-basic-block ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;
 
 : delete-conditional? ( bb -- ? )
     dup instructions>> [ drop f ] [
@@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
 
 : delete-conditional ( bb -- )
     dup successors>> first 1vector >>successors
-    [ but-last f \ ##branch boa suffix ] change-instructions
+    [ but-last \ ##branch new-insn suffix ] change-instructions
     drop ;
 
 : delete-useless-conditionals ( cfg -- cfg' )
     dup [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;

basis/compiler/cfg/utilities/utilities.factor

@@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
+: call-height ( ##call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
 : emit-primitive ( node -- )
-    word>> ##call ##branch begin-basic-block ;
+    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;

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

@@ -22,17 +22,17 @@ M: constant-expr equal?
         and
     ] [ 2drop f ] if ;
 
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
-    input-expr-counter [ dup 1 + ] change ;
-
 ! 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 )
@@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ;
 
 M: ##compare-float >expr compare>expr ;
 
-M: ##flushable >expr class next-input-expr input-expr boa ;
+M: ##flushable >expr class next-input-expr ;
 
 : init-expressions ( -- )
     0 input-expr-counter set ;

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

@@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
 
 M: ##mul-imm rewrite
     dup src2>> dup power-of-2? [
-        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
         dup number-values
     ] [ drop ] if ;
 
@@ -36,9 +36,9 @@ M: ##mul-imm rewrite
 
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr dup op>> {
-        { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
+        { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
-        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
-        { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+        { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
     } case ;
 
 : tag-fixnum-expr? ( expr -- ? )
@@ -60,11 +60,11 @@ M: ##mul-imm rewrite
 GENERIC: rewrite-tagged-comparison ( insn -- insn' )
 
 M: ##compare-imm-branch rewrite-tagged-comparison
-    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+    (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
 
 M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
-    i f \ ##compare-imm boa ;
+    i \ ##compare-imm new-insn ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
     [ dst>> ]
     [ src2>> ]
     [ src1>> vreg>vn vn>constant ] tri
-    cc= f i \ ##compare-imm boa ;
+    cc= i \ ##compare-imm new-insn ;
 
 M: ##compare rewrite
     dup flip-comparison? [
@@ -96,9 +96,9 @@ M: ##compare rewrite
 
 : rewrite-redundant-comparison ( insn -- insn' )
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
-        { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
+        { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
-        { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
-        { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
+        { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
@@ -114,18 +114,4 @@ M: ##compare-imm rewrite
         ] when
     ] when ;
 
-: dispatch-offset ( expr -- n )
-    [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
-    \ ##sub-imm eq? [ neg ] when ;
-
-: add-dispatch-offset? ( insn -- expr ? )
-    src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
-
-M: ##dispatch rewrite
-    dup add-dispatch-offset? [
-        [ clone ] dip
-        [ in1>> vn>vreg >>src ]
-        [ dispatch-offset '[ _ + ] change-offset ] bi
-    ] [ drop ] if ;
-
 M: insn rewrite ;

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

@@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
 tools.test kernel math combinators.short-circuit accessors
-sequences ;
+sequences compiler.cfg vectors arrays ;
 
 : trim-temps ( insns -- insns )
     [
@@ -13,6 +13,10 @@ sequences ;
         } 1|| [ f >>temp ] when
     ] map ;
 
+: test-value-numbering ( insns -- insns )
+    { } init-value-numbering
+    value-numbering-step ;
+
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -24,7 +28,7 @@ sequences ;
         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/= }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [
@@ -40,14 +44,14 @@ sequences ;
         T{ ##peek f V int-regs 3 D 0 }
         T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
         T{ ##replace f V int-regs 4 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [ t ] [
     {
         T{ ##peek f V int-regs 1 D 0 }
-        T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
-    } dup value-numbering =
+    } dup test-value-numbering =
 ] unit-test
 
 [ t ] [
@@ -60,7 +64,7 @@ sequences ;
         T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
         T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
         T{ ##replace f V int-regs 23 D 0 }
-    } dup value-numbering =
+    } dup test-value-numbering =
 ] unit-test
 
 [
@@ -76,7 +80,7 @@ sequences ;
         T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
         T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
         T{ ##replace f V int-regs 3 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [
@@ -94,7 +98,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -112,7 +116,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -134,7 +138,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -150,5 +154,18 @@ sequences ;
         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/= }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
+] unit-test
+
+[
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+    }
+] [
+    { V int-regs 45 } init-value-numbering
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+    } value-numbering-step
 ] unit-test

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

@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences
+compiler.cfg.local
+compiler.cfg.liveness
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.propagate
@@ -9,7 +11,16 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
-: value-numbering ( insns -- insns' )
+: number-input-values ( live-in -- )
+    [ [ f next-input-expr simplify ] dip set-vn ] each ;
+
+: init-value-numbering ( live-in -- )
     init-value-graph
     init-expressions
+    number-input-values ;
+
+: value-numbering-step ( insns -- insns' )
     [ [ number-values ] [ rewrite propagate ] bi ] map ;
+
+: value-numbering ( cfg -- cfg' )
+    [ init-value-numbering ] [ value-numbering-step ] local-optimization ;

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

@@ -1,8 +1,11 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test ;
+arrays tools.test vectors compiler.cfg kernel accessors ;
 IN: compiler.cfg.write-barrier.tests
 
+: test-write-barrier ( insns -- insns )
+    write-barriers-step ;
+
 [
     {
         T{ ##peek f V int-regs 4 D 0 f }
@@ -24,7 +27,7 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##set-slot-imm f V int-regs 6 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 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -42,7 +45,7 @@ IN: compiler.cfg.write-barrier.tests
         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 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -69,5 +72,5 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##copy f V int-regs 29 V int-regs 19 }
         T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
         T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test

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

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces assocs sets sequences locals
-compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
 
 M: insn eliminate-write-barrier ;
 
-: eliminate-write-barriers ( insns -- insns' )
+: write-barriers-step ( insns -- insns' )
     H{ } clone safe set
     H{ } clone mutated set
     H{ } clone copies set
     [ eliminate-write-barrier ] map sift ;
+
+: eliminate-write-barriers ( cfg -- cfg' )
+    [ drop ] [ write-barriers-step ] local-optimization ;

basis/compiler/codegen/codegen-tests.factor

@@ -0,0 +1,14 @@
+IN: compiler.codegen.tests
+USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
+compiler.constants ;
+
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail

basis/compiler/codegen/codegen.factor

@@ -26,14 +26,6 @@ SYMBOL: registers
 : ?register ( obj -- operand )
     dup vreg? [ register ] when ;
 
-: generate-insns ( insns -- code )
-    [
-        [
-            dup regs>> registers set
-            generate-insn
-        ] each
-    ] { } make fixup ;
-
 TUPLE: asm label code calls ;
 
 SYMBOL: calls
@@ -51,17 +43,22 @@ SYMBOL: labels
 
 : init-generator ( word -- )
     H{ } clone labels set
-    V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
     compiled-stack-traces? [ compiling-word get add-literal ] when ;
 
+: generate-insns ( asm -- code )
+    [
+        [ word>> init-generator ]
+        [
+            instructions>>
+            [ [ regs>> registers set ] [ generate-insn ] bi ] each
+        ] bi
+    ] with-fixup ;
+
 : generate ( mr -- asm )
     [
-        [ label>> ]
+        [ label>> ] [ generate-insns ] bi calls get
-        [ word>> init-generator ]
-        [ instructions>> generate-insns ] tri
-        calls get
         asm boa
     ] with-scope ;
 
@@ -92,10 +89,11 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
+M: _dispatch generate-insn
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
 
-M: ##dispatch generate-insn
+M: _dispatch-label generate-insn
-    [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+    label>> lookup-label %dispatch-label ;
 
 : >slot< ( insn -- dst obj slot tag )
     {
@@ -236,7 +234,7 @@ M: ##write-barrier generate-insn
     [ table>> register ]
     tri %write-barrier ;
 
-M: _gc generate-insn drop %gc ;
+M: ##gc generate-insn drop %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
@@ -486,7 +484,7 @@ M: _epilogue generate-insn
     stack-frame>> total-size>> %epilogue ;
 
 M: _label generate-insn
-    id>> lookup-label , ;
+    id>> lookup-label resolve-label ;
 
 M: _branch generate-insn
     label>> lookup-label %jump-label ;

basis/compiler/codegen/fixup/fixup.factor

@@ -4,48 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
 system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
 IN: compiler.codegen.fixup
 
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
+
+: add-literal ( obj -- ) literal-table get push ;
+
+! Labels
+SYMBOL: label-table
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
 
 : compiled-offset ( -- n ) building get length ;
 
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless
+    compiled-offset >>offset drop ;
+
+: offset-for-class ( class -- n )
+    rc-absolute-cell = cell 4 ? compiled-offset swap - ;
+
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+    dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
 SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
-
-TUPLE: label-fixup label class ;
-
-: label-fixup ( label class -- ) \ label-fixup boa , ;
-
-M: label-fixup fixup*
-    dup class>> rc-absolute?
-    [ "Absolute labels not supported" throw ] when
-    [ class>> ] [ label>> ] bi compiled-offset 4 - swap
-    3array label-table get push ;
-
-TUPLE: rel-fixup class type ;
-
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
 
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
-M: rel-fixup fixup*
+: add-relocation-entry ( type class offset -- )
-    [ type>> ]
+    { 0 24 28 } bitfield relocation-table get push-4 ;
-    [ class>> ]
-    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
-    { 0 24 28 } bitfield
-    relocation-table get push-4 ;
 
-M: integer fixup* , ;
+: rel-fixup ( class type -- )
-
+    swap dup offset-for-class add-relocation-entry ;
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
 
 : add-dlsym-literals ( symbol dll -- )
     [ string>symbol add-literal ] [ add-literal ] bi* ;
@@ -74,22 +74,34 @@ SYMBOL: literal-table
 : rel-here ( offset class -- )
     [ add-literal ] dip rt-here rel-fixup ;
 
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+    label>> offset>> [ "Unresolved label" throw ] unless* ;
+
+: resolve-absolute-label ( label-fixup -- )
+    dup resolve-offset neg add-literal
+    [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- label )
+    [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+    [ class>> rc-absolute? ] partition
+    [ [ resolve-absolute-label ] each ]
+    [ [ resolve-relative-label ] map concat ]
+    bi* ;
+
 : init-fixup ( -- )
-    BV{ } clone relocation-table set
+    V{ } clone literal-table set
-    V{ } clone label-table set ;
+    V{ } clone label-table set
+    BV{ } clone relocation-table set ;
 
-: resolve-labels ( labels -- labels' )
+: with-fixup ( quot -- code )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( fixup-directives -- code )
     [
         init-fixup
-        [ fixup* ] each
+        call
+        label-table [ resolve-labels ] change
         literal-table get >array
         relocation-table get >byte-array
-        label-table get resolve-labels
+        label-table get
-    ] B{ } make 4array ;
+    ] B{ } make 4array ; inline

basis/compiler/compiler.factor

@@ -3,13 +3,20 @@
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
-source-files.errors stack-checker stack-checker.state
+source-files.errors combinators.short-circuit
-stack-checker.inlining stack-checker.errors combinators.short-circuit
+
-compiler.errors compiler.units compiler.tree.builder
+stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
+
-compiler.cfg.linearization compiler.cfg.two-operand
+compiler.errors compiler.units compiler.utilities
-compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+
-compiler.utilities ;
+compiler.tree.builder
+compiler.tree.optimizer
+
+compiler.cfg.builder
+compiler.cfg.optimizer
+compiler.cfg.mr
+
+compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -89,11 +96,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
 
+: deoptimize* ( word -- * )
+    dup def>> deoptimize-with ;
+
 : ignore-error ( word error -- * )
-    drop
+    drop [ clear-compiler-error ] [ deoptimize* ] bi ;
-    [ clear-compiler-error ]
-    [ dup def>> deoptimize-with ]
-    bi ;
 
 : remember-error ( word error -- * )
     [ swap <compiler-error> compiler-error ]
@@ -117,13 +124,13 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;
 
-: frontend ( word -- nodes )
+: frontend ( word -- tree )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
     dup optimize? [
         [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
+        contains-breakpoints? [ nip deoptimize* ] [ drop ] if
-    ] [ dup def>> deoptimize-with ] if ;
+    ] [ deoptimize* ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.
@@ -143,13 +150,10 @@ t compile-dependencies? set-global
     [ compile-dependencies ]
     bi ;
 
-: backend ( nodes word -- )
+: backend ( tree word -- )
     build-cfg [
         optimize-cfg
         build-mr
-        convert-two-operand
-        linear-scan
-        build-stack-frame
         generate
         save-asm
     ] each ;

basis/compiler/tree/optimizer/optimizer.factor

@@ -25,18 +25,20 @@ SYMBOL: check-optimizer?
     ] when ;
 
 : optimize-tree ( nodes -- nodes' )
-    analyze-recursive
+    [
-    normalize
+        analyze-recursive
-    propagate
+        normalize
-    cleanup
+        propagate
-    dup run-escape-analysis? [
+        cleanup
-        escape-analysis
+        dup run-escape-analysis? [
-        unbox-tuples
+            escape-analysis
-    ] when
+            unbox-tuples
-    apply-identities
+        ] when
-    compute-def-use
+        apply-identities
-    remove-dead-code
+        compute-def-use
-    ?check
+        remove-dead-code
-    compute-def-use
+        ?check
-    optimize-modular-arithmetic
+        compute-def-use
-    finalize ;
+        optimize-modular-arithmetic
+        finalize
+    ] with-scope ;

basis/cpu/architecture/architecture.factor

@@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
 classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
 ! Register classes
 SINGLETON: int-regs
 SINGLETON: single-float-regs
@@ -51,8 +44,8 @@ HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
-HOOK: %dispatch cpu ( src temp offset -- )
+HOOK: %dispatch cpu ( src temp -- )
-HOOK: %dispatch-label cpu ( word -- )
+HOOK: %dispatch-label cpu ( label -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )

basis/cpu/ppc/ppc.factor

@@ -124,16 +124,13 @@ M: ppc %jump ( word -- )
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
-M:: ppc %dispatch ( src temp offset -- )
+M:: ppc %dispatch ( src temp -- )
     0 temp LOAD32
-    4 offset + cells rc-absolute-ppc-2/2 rel-here
+    4 cells rc-absolute-ppc-2/2 rel-here
     temp temp src LWZX
     temp MTCTR
     BCTR ;
 
-M: ppc %dispatch-label ( word -- )
-    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
     temp tag neg ; inline

basis/cpu/x86/32/32.factor

@@ -26,10 +26,10 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 ECX ;
 M: x86.32 temp-reg-2 EDX ;
 
-M:: x86.32 %dispatch ( src temp offset -- )
+M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     src HEX: ffffffff ADD
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Go
     src HEX: 7f [+] JMP
     ! Fix up the displacement above

basis/cpu/x86/64/64.factor

@@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
-M:: x86.64 %dispatch ( src temp offset -- )
+M:: x86.64 %dispatch ( src temp -- )
     ! Load jump table base.
     temp HEX: ffffffff MOV
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Add jump table base
     src temp ADD
     src HEX: 7f [+] JMP

basis/cpu/x86/x86.factor

@@ -74,13 +74,13 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )
-    [ building get [ integer? ] count dup ] dip align swap - ;
+    [ building get length dup ] dip align swap - ;
 
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch-label ( word -- )
+M: x86 %dispatch-label ( label -- )
-    0 cell, rc-absolute-cell rel-word ;
+    0 cell, rc-absolute-cell label-fixup ;
 
 :: (%slot) ( obj slot tag temp -- op )
     temp slot obj [+] LEA

core/assocs/assocs-tests.factor

@@ -130,3 +130,7 @@ unit-test
 
 [ 1 f ] [ 1 H{ } ?at ] unit-test
 [ 2 t ] [ 1 H{ { 1 2 } } ?at ] 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

core/assocs/assocs.factor

@@ -22,6 +22,9 @@ M: assoc assoc-like drop ;
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
 
+: maybe-set-at ( value key assoc -- changed? )
+    3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
+
 <PRIVATE
 
 : (assoc-each) ( assoc quot -- seq quot' )

extra/cursors/cursors.factor

@@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- )
 ERROR: cursor-ended cursor ;
 
 : cursor-get ( cursor -- obj )
-   dup cursor-done?
+    dup cursor-done?
-   [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+    [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
 
-: find-done? ( quot cursor -- ? )
+: find-done? ( cursor quot -- ? )
-   dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
+    over cursor-done?
-
+    [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
-: cursor-until ( quot cursor -- )
-   [ find-done? not ]
-   [ cursor-advance drop ] bi-curry bi-curry while ; inline
 
+: cursor-until ( cursor quot -- )
+    [ find-done? not ]
+    [ drop cursor-advance ] bi-curry bi-curry while ; inline
+ 
 : cursor-each ( cursor quot -- )
-   [ f ] compose swap cursor-until ; inline
+    [ f ] compose cursor-until ; inline
 
 : cursor-find ( cursor quot -- obj ? )
-   swap [ cursor-until ] keep
+    [ cursor-until ] [ drop ] 2bi
-   dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+    dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
 
 : cursor-any? ( cursor quot -- ? )
-   cursor-find nip ; inline
+    cursor-find nip ; inline
 
 : cursor-all? ( cursor quot -- ? )
-   [ not ] compose cursor-any? not ; inline
+    [ not ] compose cursor-any? not ; inline
 
 : cursor-map-quot ( quot to -- quot' )
-   [ [ call ] dip cursor-write ] 2curry ; inline
+    [ [ call ] dip cursor-write ] 2curry ; inline
 
 : cursor-map ( from to quot -- )
    swap cursor-map-quot cursor-each ; inline
@@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ;
     [ cursor-write ] 2curry when ; inline
 
 : cursor-filter-quot ( quot to -- quot' )
-   [ cursor-write-if ] 2curry ; inline
+    [ cursor-write-if ] 2curry ; inline
 
 : cursor-filter ( from to quot -- )
-   swap cursor-filter-quot cursor-each ; inline
+    swap cursor-filter-quot cursor-each ; inline
 
 TUPLE: from-sequence { seq sequence } { n integer } ;
 
@@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? )
     >from-sequence< length >= ;
 
 M: from-sequence cursor-valid?
-   >from-sequence< bounds-check? not ;
+    >from-sequence< bounds-check? not ;
 
 M: from-sequence cursor-get-unsafe
-   >from-sequence< nth-unsafe ;
+    >from-sequence< nth-unsafe ;
 
 M: from-sequence cursor-advance
-   [ 1+ ] change-n drop ;
+    [ 1+ ] change-n drop ;
 
 : >input ( seq -- cursor )
-   0 from-sequence boa ; inline
+    0 from-sequence boa ; inline
 
 : iterate ( seq quot iterator -- )
-   [ >input ] 2dip call ; inline
+    [ >input ] 2dip call ; inline
 
 : each ( seq quot -- ) [ cursor-each ] iterate ; inline
 : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
@@ -82,18 +83,19 @@ M: from-sequence cursor-advance
 TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
 
 M: to-sequence cursor-write
-   seq>> push ;
+    seq>> push ;
 
 : freeze ( cursor -- seq )
-   [ seq>> ] [ exemplar>> ] bi like ; inline
+    [ seq>> ] [ exemplar>> ] bi like ; inline
 
 : >output ( seq -- cursor )
-   [ [ length ] keep new-resizable ] keep
+    [ [ length ] keep new-resizable ] keep
-   to-sequence boa ; inline
+    to-sequence boa ; inline
 
 : transform ( seq quot transformer -- newseq )
-   [ [ >input ] [ >output ] bi ] 2dip
+    [ [ >input ] [ >output ] bi ] 2dip
-   [ call ] [ 2drop freeze ] 3bi ; inline
+    [ call ]
+    [ 2drop freeze ] 3bi ; inline
 
 : map ( seq quot -- ) [ cursor-map ] transform ; inline
 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

extra/fuel/fuel.factor

@@ -134,14 +134,16 @@ PRIVATE>
 
 ! Scaffold support
 
+: fuel-scaffold-name ( devname -- )
+    [ developer-name set ] when* ;
+
 : fuel-scaffold-vocab ( root name devname -- )
-    developer-name set dup [ scaffold-vocab ] dip
+    [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
     dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-help ( name devname -- )
-    developer-name set
+    [ fuel-scaffold-name dup require dup scaffold-help ] with-scope
-    dup require dup scaffold-help vocab-docs-path
+    vocab-docs-path (normalize-path) fuel-eval-set-result ;
-    (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
 

extra/irc/client/internals/internals-tests.factor

@@ -85,6 +85,18 @@ M: mb-writer dispose drop ;
     ] with-irc
 ] unit-test
 
+! Test connect with password
+{ V{ "PASS password" "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+    "someserver" irc-port "factorbot" "password" <irc-profile> <irc-client>
+    [ 2drop <test-stream> ] >>connect
+    [
+        (connect-irc)
+        (do-login)
+        irc> stream>> out>> lines>>
+        (terminate-irc)
+    ] with-irc
+] unit-test
+
 ! Test join
 [ { "JOIN #factortest" } [
       "#factortest" %join %pop-output-line

extra/irc/client/internals/internals.factor

@@ -16,6 +16,7 @@ IN: irc.client.internals
 
 : /NICK ( nick -- ) "NICK " prepend irc-print ;
 : /PONG ( text -- ) "PONG " prepend irc-print ;
+: /PASS ( password -- ) "PASS " prepend irc-print ;
 
 : /LOGIN ( nick -- )
     dup /NICK
@@ -44,7 +45,11 @@ IN: irc.client.internals
         in-messages>> [ irc-connected ] dip mailbox-put
     ] [ (terminate-irc) ] if* ;
 
-: (do-login) ( -- ) irc> nick>> /LOGIN ;
+: (do-login) ( -- )
+     irc>
+     [ profile>> password>> [ /PASS ] when* ]
+     [ nick>> /LOGIN ]
+     bi ;
 
 GENERIC: initialize-chat ( chat -- )
 M: irc-chat         initialize-chat drop ;

extra/managed-server/chat/chat.factor

@@ -18,6 +18,9 @@ chat-docs [ H{ } clone ] initialize
 
 CONSTANT: line-beginning "-!- "
 
+: send-line ( string -- )
+    write "\r\n" write flush ;
+
 : handle-me ( string -- )
     [
         [ "* " username " " ] dip
@@ -29,15 +32,15 @@ CONSTANT: line-beginning "-!- "
 : handle-help ( string -- )
     [
         "Commands: "
-        commands get keys natural-sort ", " join append print flush
+        commands get keys natural-sort ", " join append send-line
     ] [
         chat-docs get ?at
-        [ print flush ]
+        [ send-line ]
-        [ "Unknown command: " prepend print flush ] if
+        [ "Unknown command: " prepend send-line ] if
     ] if-empty ;
 
 : usage ( string -- )
-    chat-docs get at print flush ;
+    chat-docs get at send-line ;
 
 : username-taken-string ( username -- string )
     "The username ``" "'' is already in use; try again." surround ;
@@ -53,7 +56,7 @@ CONSTANT: line-beginning "-!- "
         "nick" usage
     ] [
         dup clients key? [
-            username-taken-string print flush
+            username-taken-string send-line
         ] [
             [ username swap warn-name-changed ]
             [ username clients rename-at ]
@@ -70,12 +73,12 @@ CONSTANT: line-beginning "-!- "
 Displays the documentation for a command.">
 "help" add-command
 
-[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
 <" Syntax: /who
 Shows the list of connected users.">
 "who" add-command
 
-[ drop gmt timestamp>rfc822 print flush ]
+[ drop gmt timestamp>rfc822 send-line ]
 <" Syntax: /time
 Returns the current GMT time."> "time" add-command
 
@@ -96,7 +99,7 @@ Disconnects a user from the chat server."> "quit" add-command
     dup " " split1 swap >lower commands get at* [
         call( string -- ) drop
     ] [
-        2drop "Unknown command: " prepend print flush
+        2drop "Unknown command: " prepend send-line
     ] if ;
 
 : <chat-server> ( port -- managed-server )
@@ -123,7 +126,7 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string print flush ;
+    username username-taken-string send-line ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

misc/fuel/fuel-scaffold.el

@@ -26,9 +26,10 @@
   "Options for FUEL's scaffolding."
   :group 'fuel)
 
-(defcustom fuel-scaffold-developer-name user-full-name
+(defcustom fuel-scaffold-developer-name nil
   "The name to be inserted as yours in scaffold templates."
-  :type 'string
+  :type '(choice string
+                 (const :tag "Factor's value for developer-name" nil))
   :group 'fuel-scaffold)
 
 

misc/fuel/fuel-syntax.el

@@ -59,7 +59,7 @@
     "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
-    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
     "TUPLE:" "t" "t?" "TYPEDEF:"
     "UNION:" "USE:" "USING:"
     "VARS:"))
@@ -109,7 +109,7 @@
   (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
           (regexp-opt
            '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
-             "SYMBOL" "RENAME"))))
+             "SYMBOL" "SYNTAX" "RENAME"))))
 
 (defconst fuel-syntax--alias-definition-regex
   "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@@ -156,6 +156,7 @@
                                            "INTERSECTION:"
                                            "M" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
+                                           "SYNTAX"
                                            "PREDICATE" "PRIMITIVE"
                                            "UNION"))
 

vm/code_block.cpp

@@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 	case RT_XT_PIC_TAIL:
 		return (cell)word_xt_pic_tail(untag<word>(ARG));
 	case RT_HERE:
-		return offset + (short)untag_fixnum(ARG);
+	{
+		fixnum arg = untag_fixnum(ARG);
+		return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+	}
 	case RT_THIS:
 		return (cell)(compiled + 1);
 	case RT_STACK_CHAIN: