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

diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor
index 42655aceb8e4c55ba8290b7cbe0f1ad5cbf63dc8..cdec87b61dc1f2f4a31689ea9e74fce89e560266 100644 (file)
--- a/basis/bit-arrays/bit-arrays.factor
+++ b/basis/bit-arrays/bit-arrays.factor
@@ -27,6 +27,18 @@ TUPLE: bit-array
     [ [ length bits>cells ] keep ] dip swap underlying>>
     '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
 
+: clean-up ( bit-array -- )
+    ! Zero bits after the end.
+    dup underlying>> empty? [ drop ] [
+        [
+            [ underlying>> length 8 * ] [ length ] bi -
+            8 swap - -1 swap shift bitnot
+        ]
+        [ underlying>> last bitand ]
+        [ underlying>> set-last ]
+        tri
+    ] if ; inline
+
 PRIVATE>
 
 : <bit-array> ( n -- bit-array )
@@ -68,7 +80,8 @@ M: bit-array resize
         [ bits>bytes ] [ underlying>> ] bi*
         resize-byte-array
     ] 2bi
-    bit-array boa ;
+    bit-array boa
+    dup clean-up ;
 
 M: bit-array byte-length length 7 + -3 shift ;
 

diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor
index b4c72234355ecbb24c883a005abb45a13780945a..08c43f203ccd451876f411d07045d336bc5f51db 100644 (file)
--- a/basis/compiler/cfg/block-joining/block-joining.factor
+++ b/basis/compiler/cfg/block-joining/block-joining.factor
@@ -8,9 +8,6 @@ IN: compiler.cfg.block-joining
 ! Joining blocks that are not calls and are connected by a single CFG edge.
 ! Predecessors must be recomputed after this. Also this pass does not
 ! update ##phi nodes and should therefore only run before stack analysis.
-: predecessor ( bb -- pred )
-    predecessors>> first ; inline
-
 : join-block? ( bb -- ? )
     {
         [ kill-block? not ]

diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
index 8618932e14d973c45b30399c9de48cfb86a39d79..e5583a14ab0f2f4ec39ecf0b3762aca94cb3f7e4 100644 (file)
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -7,11 +7,12 @@ compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
 : clone-instructions ( insns -- insns' )
-    [ clone dup fresh-insn-temps ] map ;
+    [ clone dup rename-insn-temps ] map ;
 
 : clone-basic-block ( bb -- bb' )
-    ! The new block gets the same RPO number as the old one.
-    ! This is just to make 'back-edge?' work.
+    ! The new block temporarily gets the same RPO number as the old one,
+    ! until the next time RPO is computed. This is just to make
+    ! 'back-edge?' work.
     <basic-block>
         swap
         [ instructions>> clone-instructions >>instructions ]

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 066d20ddec8b7512c121538f219b83b10287c2e0..e08b3b25bb58b958a8c5bcdd6d00e680bd3fc05d 100644 (file)
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -6,35 +6,35 @@ compiler.constants combinators compiler.cfg.registers
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
-: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+: new-insn ( ... class -- insn ) f swap boa ; inline
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 TUPLE: insn ;
 
 ! Instruction with no side effects; if 'out' is never read, we
 ! can eliminate it.
-TUPLE: ##flushable < insn { dst vreg } ;
+TUPLE: ##flushable < insn dst ;
 
 ! Instruction which is referentially transparent; we can replace
 ! repeated computation with a reference to a previous value
 TUPLE: ##pure < ##flushable ;
 
-TUPLE: ##unary < ##pure { src vreg } ;
-TUPLE: ##unary/temp < ##unary { temp vreg } ;
-TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
-TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
+TUPLE: ##unary < ##pure src ;
+TUPLE: ##unary/temp < ##unary temp ;
+TUPLE: ##binary < ##pure src1 src2 ;
+TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
 TUPLE: ##commutative < ##binary ;
 TUPLE: ##commutative-imm < ##binary-imm ;
 
 ! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn { src vreg } ;
+TUPLE: ##effect < insn src ;
 
 ! Read/write ops: candidates for alias analysis
 TUPLE: ##read < ##flushable ;
 TUPLE: ##write < ##effect ;
 
-TUPLE: ##alien-getter < ##flushable { src vreg } ;
-TUPLE: ##alien-setter < ##effect { value vreg } ;
+TUPLE: ##alien-getter < ##flushable src ;
+TUPLE: ##alien-setter < ##effect value ;
 
 ! Stack operations
 INSN: ##load-immediate < ##pure { val integer } ;
@@ -63,14 +63,14 @@ INSN: ##no-tco ;
 INSN: ##dispatch src temp ;
 
 ! Slot access
-INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
-INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
-INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+INSN: ##slot < ##read obj slot { tag integer } temp ;
+INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
+INSN: ##set-slot < ##write obj slot { tag integer } temp ;
+INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
 
 ! String element access
-INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
-INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##string-nth < ##flushable obj index temp ;
+INSN: ##set-string-nth-fast < ##effect obj index temp ;
 
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
@@ -150,7 +150,7 @@ INSN: ##set-alien-float < ##alien-setter ;
 INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
-INSN: ##allot < ##flushable size class { temp vreg } ;
+INSN: ##allot < ##flushable size class temp ;
 
 UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
 
@@ -173,10 +173,10 @@ INSN: ##branch ;
 INSN: ##phi < ##pure inputs ;
 
 ! Conditionals
-TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
+TUPLE: ##conditional-branch < insn src1 src2 cc ;
 
 INSN: ##compare-branch < ##conditional-branch ;
-INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
+INSN: ##compare-imm-branch src1 { src2 integer } cc ;
 
 INSN: ##compare < ##binary cc temp ;
 INSN: ##compare-imm < ##binary-imm cc temp ;
@@ -185,12 +185,12 @@ INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
 ! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ;
+TUPLE: ##fixnum-overflow < insn dst src1 src2 ;
 INSN: ##fixnum-add < ##fixnum-overflow ;
 INSN: ##fixnum-sub < ##fixnum-overflow ;
 INSN: ##fixnum-mul < ##fixnum-overflow ;
 
-INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
+INSN: ##gc temp1 temp2 live-values ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -204,22 +204,22 @@ INSN: _loop-entry ;
 INSN: _dispatch src temp ;
 INSN: _dispatch-label label ;
 
-TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
+TUPLE: _conditional-branch < insn label src1 src2 cc ;
 
 INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
+INSN: _compare-imm-branch label src1 { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
 ! Overflowing arithmetic
-TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ;
+TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
 INSN: _fixnum-add < _fixnum-overflow ;
 INSN: _fixnum-sub < _fixnum-overflow ;
 INSN: _fixnum-mul < _fixnum-overflow ;
 
 TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
-INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
+INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers

diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index e8f8641e7dcde1fcdb2ac9e59670c1edd0bfbfef..ab1c9599e5cf90f168cadd36aab4b85b6d4bb734 100644 (file)
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/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>> 2 head* f <effect> ;
+    boa-effect in>> but-last f <effect> ;
 
 SYNTAX: INSN:
-    parse-tuple-definition { "regs" "insn#" } append
+    parse-tuple-definition "insn#" suffix
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
+    [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
     3tri ;

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 3664f58b1eb3d4e5fc9e5f9a9b375d277deed808..071118d60fde715d04c6824d1038b60b4da4d6eb 100644 (file)
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -9,6 +9,7 @@ compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.renaming.functor
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals ;
@@ -16,10 +17,16 @@ IN: compiler.cfg.linear-scan.assignment
 
 ! This contains both active and inactive intervals; any interval
 ! such that start <= insn# <= end is in this set.
-SYMBOL: pending-intervals
+SYMBOL: pending-interval-heap
+SYMBOL: pending-interval-assoc
 
-: add-active ( live-interval -- )
-    dup end>> pending-intervals get heap-push ;
+: add-pending ( live-interval -- )
+    [ dup end>> pending-interval-heap get heap-push ]
+    [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
+    bi ;
+
+: remove-pending ( live-interval -- )
+    vreg>> pending-interval-assoc get delete-at ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -37,7 +44,8 @@ SYMBOL: register-live-ins
 SYMBOL: register-live-outs
 
 : init-assignment ( live-intervals -- )
-    <min-heap> pending-intervals set
+    <min-heap> pending-interval-heap set
+    H{ } clone pending-interval-assoc set
     <min-heap> unhandled-intervals set
     H{ } clone register-live-ins set
     H{ } clone register-live-outs set
@@ -49,16 +57,19 @@ SYMBOL: register-live-outs
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
 
+: expire-interval ( live-interval -- )
+    [ remove-pending ] [ handle-spill ] bi ;
+
 : (expire-old-intervals) ( n heap -- )
     dup heap-empty? [ 2drop ] [
         2dup heap-peek nip <= [ 2drop ] [
-            dup heap-pop drop handle-spill
+            dup heap-pop drop expire-interval
             (expire-old-intervals)
         ] if
     ] if ;
 
 : expire-old-intervals ( n -- )
-    pending-intervals get (expire-old-intervals) ;
+    pending-interval-heap get (expire-old-intervals) ;
 
 : insert-reload ( live-interval -- )
     [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
@@ -66,45 +77,31 @@ SYMBOL: register-live-outs
 : handle-reload ( live-interval -- )
     dup reload-from>> [ insert-reload ] [ drop ] if ;
 
-: activate-new-intervals ( n -- )
-    #! Any live intervals which start on the current instruction
-    #! are added to the active set.
-    unhandled-intervals get dup heap-empty? [ 2drop ] [
-        2dup heap-peek drop start>> = [
-            heap-pop drop
-            [ add-active ] [ handle-reload ] bi
-            activate-new-intervals
+: activate-interval ( live-interval -- )
+    [ add-pending ] [ handle-reload ] bi ;
+
+: (activate-new-intervals) ( n heap -- )
+    dup heap-empty? [ 2drop ] [
+        2dup heap-peek nip = [
+            dup heap-pop drop activate-interval
+            (activate-new-intervals)
         ] [ 2drop ] if
     ] if ;
 
+: activate-new-intervals ( n -- )
+    unhandled-intervals get (activate-new-intervals) ;
+
 : prepare-insn ( n -- )
     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 
 GENERIC: assign-registers-in-insn ( insn -- )
 
-: register-mapping ( live-intervals -- alist )
-    [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
-
-: all-vregs ( insn -- vregs )
-    [ [ temp-vregs ] [ uses-vregs ] bi append ]
-    [ defs-vreg ] bi
-    [ suffix ] when* ;
+: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
 
-SYMBOL: check-assignment?
-
-ERROR: overlapping-registers intervals ;
-
-: check-assignment ( intervals -- )
-    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
-    dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
-
-: active-intervals ( n -- intervals )
-    pending-intervals get heap-values [ covers? ] with filter
-    check-assignment? get [ dup check-assignment ] when ;
+RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 
 M: vreg-insn assign-registers-in-insn
-    dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
-    extract-keys >>regs drop ;
+    [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
 M: ##gc assign-registers-in-insn
     ! This works because ##gc is always the first instruction
@@ -115,33 +112,22 @@ M: ##gc assign-registers-in-insn
 
 M: insn assign-registers-in-insn drop ;
 
-: compute-live-spill-slots ( vregs -- assoc )
-    spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
-
-: compute-live-registers ( n -- assoc )
-    active-intervals register-mapping ;
-
-ERROR: bad-live-values live-values ;
-
-: check-live-values ( assoc -- assoc )
-    check-assignment? get [
-        dup values [ not ] any? [ bad-live-values ] when
-    ] when ;
-
-: compute-live-values ( vregs n -- assoc )
+: compute-live-values ( vregs -- assoc )
     ! If a live vreg is not in active or inactive, then it must have been
     ! spilled.
-    [ compute-live-spill-slots ] [ compute-live-registers ] bi*
-    assoc-union check-live-values ;
+    dup assoc-empty? [
+        pending-interval-assoc get
+        '[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
+    ] unless ;
 
 : begin-block ( bb -- )
     dup basic-block set
     dup block-from activate-new-intervals
-    [ [ live-in ] [ block-from ] bi compute-live-values ] keep
+    [ live-in compute-live-values ] keep
     register-live-ins get set-at ;
 
 : end-block ( bb -- )
-    [ [ live-out ] [ block-to ] bi compute-live-values ] keep
+    [ live-out compute-live-values ] keep
     register-live-outs get set-at ;
 
 ERROR: bad-vreg vreg ;

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 7362d185b4523222f9ad655260b75bddf34d7407..1673b1b365897852f72c5c95a1a58975e6b56216 100644 (file)
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -21,10 +21,7 @@ compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.debugger ;
 
-FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
-
 check-allocation? on
-check-assignment? on
 check-numbering? on
 
 [

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 68f7544e8e12a472eae9640a875f64060ed45f0c..b1b44cde44d68a24ec1e677f6f4b1d57851dedfa 100644 (file)
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -47,12 +47,19 @@ H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
 H{ } clone spill-temps set
 
 [
-    {
-        T{ _spill { src 0 } { class int-regs } { n 10 } }
-        T{ _copy { dst 0 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 10 } }
-    }
+    t
 ] [
     { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
-    mapping-instructions
+    mapping-instructions {
+        {
+            T{ _spill { src 0 } { class int-regs } { n 10 } }
+            T{ _copy { dst 0 } { src 1 } { class int-regs } }
+            T{ _reload { dst 1 } { class int-regs } { n 10 } }
+        }
+        {
+            T{ _spill { src 1 } { class int-regs } { n 10 } }
+            T{ _copy { dst 1 } { src 0 } { class int-regs } }
+            T{ _reload { dst 0 } { class int-regs } { n 10 } }
+        }
+    } member?
 ] unit-test
\ No newline at end of file

diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index cc148d34d8d92e8997cca98f864b2b4b3f536828..97fb3205c2b5c3e6b36e81219d54f9fa418af2f5 100755 (executable)
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -3,34 +3,30 @@
 USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals cpu.architecture
 compiler.cfg
-compiler.cfg.rpo
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities
+compiler.cfg.linearization.order ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
 : linearize-basic-block ( bb -- )
-    [ number>> _label ]
+    [ block-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
-
-: emit-loop-entry? ( bb successor -- ? )
-    [ back-edge? not ] [ nip loop-entry? ] 2bi and ;
+    ! If our successor immediately follows us in linearization
+    ! order then we don't need to branch.
+    [ block-number ] bi@ 1 - = ; inline
 
 : emit-branch ( bb successor -- )
-    2dup emit-loop-entry? [ _loop-entry ] when
-    2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
+    2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
 
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
@@ -44,37 +40,34 @@ M: ##branch linearize-insn
 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
     [ (binary-conditional) ]
     [ drop dup successors>> second useless-branch? ] 2bi
-    [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
-
-: with-regs ( insn quot -- )
-    over regs>> [ call ] dip building get last (>>regs) ; inline
+    [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
 
 M: ##compare-branch linearize-insn
-    [ binary-conditional _compare-branch ] with-regs emit-branch ;
+    binary-conditional _compare-branch emit-branch ;
 
 M: ##compare-imm-branch linearize-insn
-    [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
+    binary-conditional _compare-imm-branch emit-branch ;
 
 M: ##compare-float-branch linearize-insn
-    [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+    binary-conditional _compare-float-branch emit-branch ;
 
 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
-    [ dup successors number>> ]
+    [ dup successors block-number ]
     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
 
 M: ##fixnum-add linearize-insn
-    [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
+    overflow-conditional _fixnum-add emit-branch ;
 
 M: ##fixnum-sub linearize-insn
-    [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
+    overflow-conditional _fixnum-sub emit-branch ;
 
 M: ##fixnum-mul linearize-insn
-    [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
+    overflow-conditional _fixnum-mul emit-branch ;
 
 M: ##dispatch linearize-insn
     swap
-    [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
-    [ successors>> [ number>> _dispatch-label ] each ]
+    [ [ src>> ] [ temp>> ] bi _dispatch ]
+    [ successors>> [ block-number _dispatch-label ] each ]
     bi* ;
 
 : (compute-gc-roots) ( n live-values -- n )
@@ -105,22 +98,20 @@ M: ##dispatch linearize-insn
 
 M: ##gc linearize-insn
     nip
+    [ temp1>> ]
+    [ temp2>> ]
     [
-        [ temp1>> ]
-        [ temp2>> ]
-        [
-            live-values>>
-            [ compute-gc-roots ]
-            [ count-gc-roots ]
-            [ gc-roots-size ]
-            tri
-        ] tri
-        _gc
-    ] with-regs ;
+        live-values>>
+        [ compute-gc-roots ]
+        [ count-gc-roots ]
+        [ gc-roots-size ]
+        tri
+    ] tri
+    _gc ;
 
 : linearize-basic-blocks ( cfg -- insns )
     [
-        [ [ linearize-basic-block ] each-basic-block ]
+        [ linearization-order [ linearize-basic-block ] each ]
         [ spill-counts>> _spill-counts ]
         bi
     ] { } make ;

diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor
new file mode 100644 (file)
index 0000000..c09c296
--- /dev/null
+++ b/basis/compiler/cfg/linearization/order/order.factor
@@ -0,0 +1,73 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel make
+namespaces sequences combinators combinators.short-circuit
+fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
+IN: compiler.cfg.linearization.order
+
+! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+
+<PRIVATE
+
+SYMBOLS: work-list loop-heads visited numbers next-number ;
+
+: visited? ( bb -- ? ) visited get key? ;
+
+: add-to-work-list ( bb -- )
+    dup visited get key? [ drop ] [
+        work-list get push-back
+    ] if ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+    dup {
+        [ predecessor visited? not ]
+        [ predecessors>> length 1 = ]
+        [ predecessor successors>> length 1 = ]
+        [ [ number>> ] [ predecessor number>> ] bi > ]
+    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+    dup find-back-edge dup visited? [ drop ] [
+        nip (find-alternate-loop-head)
+    ] if ;
+
+: predecessors-ready? ( bb -- ? )
+    [ predecessors>> ] keep '[
+        _ 2dup back-edge?
+        [ 2drop t ] [ drop visited? ] if
+    ] all? ;
+
+: process-successor ( bb -- )
+    dup predecessors-ready? [
+        dup loop-entry? [ find-alternate-loop-head ] when
+        add-to-work-list
+    ] [ drop ] if ;
+
+: assign-number ( bb -- )
+    next-number [ get ] [ inc ] bi swap numbers get set-at ;
+
+: process-block ( bb -- )
+    {
+        [ , ]
+        [ assign-number ]
+        [ visited get conjoin ]
+        [ successors>> <reversed> [ process-successor ] each ]
+    } cleave ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+    ! We call 'post-order drop' to ensure blocks receive their
+    ! RPO numbers.
+    <dlist> work-list set
+    H{ } clone visited set
+    H{ } clone numbers set
+    0 next-number set
+    [ post-order drop ]
+    [ entry>> add-to-work-list ] bi
+    [ work-list get [ process-block ] slurp-deque ] { } make ;
+
+: block-number ( bb -- n ) numbers get at ;

diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor
index 2a9d8d4911449dd6da3b95429c32df8d985e1099..ffb824f0937e740dddb94cd344b5cd8eb9d33fc5 100644 (file)
--- a/basis/compiler/cfg/renaming/functor/functor.factor
+++ b/basis/compiler/cfg/renaming/functor/functor.factor
@@ -4,10 +4,11 @@ USING: functors assocs kernel accessors compiler.cfg.instructions
 lexer parser ;
 IN: compiler.cfg.renaming.functor
 
-FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT -- )
+FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
 
 rename-insn-defs DEFINES ${NAME}-insn-defs
 rename-insn-uses DEFINES ${NAME}-insn-uses
+rename-insn-temps DEFINES ${NAME}-insn-temps
 
 WHERE
 
@@ -111,6 +112,53 @@ M: ##phi rename-insn-uses
 
 M: insn rename-insn-uses drop ;
 
+GENERIC: rename-insn-temps ( insn -- )
+
+M: ##write-barrier rename-insn-temps
+    TEMP-QUOT change-card#
+    TEMP-QUOT change-table
+    drop ;
+
+M: ##unary/temp rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##allot rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##dispatch rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##slot rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##set-slot rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##string-nth rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##set-string-nth-fast rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##compare rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##compare-imm rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##compare-float rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: ##gc rename-insn-temps
+    TEMP-QUOT change-temp1
+    TEMP-QUOT change-temp2
+    drop ;
+
+M: _dispatch rename-insn-temps
+    TEMP-QUOT change-temp drop ;
+
+M: insn rename-insn-temps drop ;
+
 ;FUNCTOR
 
-SYNTAX: RENAMING: scan scan-object scan-object define-renaming ;
\ No newline at end of file
+SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ;
\ No newline at end of file

diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor
index 9de3fdd8d8f28bf367ee309ce94f5f4af28b575c..3d032f75102443677d9057504877dbcb043f6355 100644 (file)
--- a/basis/compiler/cfg/renaming/renaming.factor
+++ b/basis/compiler/cfg/renaming/renaming.factor
@@ -10,54 +10,7 @@ SYMBOL: renamings
 : rename-value ( vreg -- vreg' )
     renamings get ?at drop ;
 
-RENAMING: rename [ rename-value ] [ rename-value ]
-
-: fresh-vreg ( vreg -- vreg' )
+: fresh-value ( vreg -- vreg' )
     reg-class>> next-vreg ;
 
-GENERIC: fresh-insn-temps ( insn -- )
-
-M: ##write-barrier fresh-insn-temps
-    [ fresh-vreg ] change-card#
-    [ fresh-vreg ] change-table
-    drop ;
-
-M: ##unary/temp fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##allot fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##dispatch fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##slot fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##set-slot fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##string-nth fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##set-string-nth-fast fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##compare fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##compare-imm fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##compare-float fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: ##gc fresh-insn-temps
-    [ fresh-vreg ] change-temp1
-    [ fresh-vreg ] change-temp2
-    drop ;
-
-M: _dispatch fresh-insn-temps
-    [ fresh-vreg ] change-temp drop ;
-
-M: insn fresh-insn-temps drop ;
\ No newline at end of file
+RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]

diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor
index 3bbbb887f0456bb880e20ba066263d39afbae2e9..d2c7698999e7a39211e64aea3ce75c904e97f360 100644 (file)
--- a/basis/compiler/cfg/ssa/construction/construction.factor
+++ b/basis/compiler/cfg/ssa/construction/construction.factor
@@ -84,7 +84,7 @@ SYMBOLS: stacks pushed ;
 : top-name ( vreg -- vreg' )
     stacks get at last ;
 
-RENAMING: ssa-rename [ gen-name ] [ top-name ]
+RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
 
 GENERIC: rename-insn ( insn -- )
 

diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index d242d5d90d6c20ebe0488de185daae229e1513de..f01b10f6eb9d6475e16296776ed58942ce271e16 100644 (file)
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -57,3 +57,7 @@ SYMBOL: visited
 
 : if-has-phis ( bb quot: ( bb -- ) -- )
     [ dup has-phis? ] dip [ drop ] if ; inline
+
+: predecessor ( bb -- pred )
+    predecessors>> first ; inline
+

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 993edbf812b6e15374269f0a8e7e4a7dc2000cf1..f9a4786eb519ecac82dfc65360c220c2a265ddfc 100755 (executable)
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -24,14 +24,6 @@ H{ } clone insn-counts set-global
 
 GENERIC: generate-insn ( insn -- )
 
-SYMBOL: registers
-
-: register ( vreg -- operand )
-    registers get at [ "Bad value" throw ] unless* ;
-
-: ?register ( obj -- operand )
-    dup vreg? [ register ] when ;
-
 TUPLE: asm label code calls ;
 
 SYMBOL: calls
@@ -60,9 +52,8 @@ SYMBOL: labels
             instructions>>
             [
                 [ class insn-counts get inc-at ]
-                [ regs>> registers set ]
                 [ generate-insn ]
-                tri
+                bi
             ] each
         ] bi
     ] with-fixup ;
@@ -79,16 +70,16 @@ SYMBOL: labels
 M: ##no-tco generate-insn drop ;
 
 M: ##load-immediate generate-insn
-    [ dst>> register ] [ val>> ] bi %load-immediate ;
+    [ dst>> ] [ val>> ] bi %load-immediate ;
 
 M: ##load-reference generate-insn
-    [ dst>> register ] [ obj>> ] bi %load-reference ;
+    [ dst>> ] [ obj>> ] bi %load-reference ;
 
 M: ##peek generate-insn
-    [ dst>> register ] [ loc>> ] bi %peek ;
+    [ dst>> ] [ loc>> ] bi %peek ;
 
 M: ##replace generate-insn
-    [ src>> register ] [ loc>> ] bi %replace ;
+    [ src>> ] [ loc>> ] bi %replace ;
 
 M: ##inc-d generate-insn n>> %inc-d ;
 
@@ -103,7 +94,7 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 M: ##return generate-insn drop %return ;
 
 M: _dispatch generate-insn
-    [ src>> register ] [ temp>> register ] bi %dispatch ;
+    [ src>> ] [ temp>> ] bi %dispatch ;
 
 M: _dispatch-label generate-insn
     label>> lookup-label
@@ -111,56 +102,34 @@ M: _dispatch-label generate-insn
     rc-absolute-cell label-fixup ;
 
 : >slot< ( insn -- dst obj slot tag )
-    {
-        [ dst>> register ]
-        [ obj>> register ]
-        [ slot>> ?register ]
-        [ tag>> ]
-    } cleave ; inline
+    { [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
 
 M: ##slot generate-insn
-    [ >slot< ] [ temp>> register ] bi %slot ;
+    [ >slot< ] [ temp>> ] bi %slot ;
 
 M: ##slot-imm generate-insn
     >slot< %slot-imm ;
 
 : >set-slot< ( insn -- src obj slot tag )
-    {
-        [ src>> register ]
-        [ obj>> register ]
-        [ slot>> ?register ]
-        [ tag>> ]
-    } cleave ; inline
+    { [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
 
 M: ##set-slot generate-insn
-    [ >set-slot< ] [ temp>> register ] bi %set-slot ;
+    [ >set-slot< ] [ temp>> ] bi %set-slot ;
 
 M: ##set-slot-imm generate-insn
     >set-slot< %set-slot-imm ;
 
 M: ##string-nth generate-insn
-    {
-        [ dst>> register ]
-        [ obj>> register ]
-        [ index>> register ]
-        [ temp>> register ]
-    } cleave %string-nth ;
+    { [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
 
 M: ##set-string-nth-fast generate-insn
-    {
-        [ src>> register ]
-        [ obj>> register ]
-        [ index>> register ]
-        [ temp>> register ]
-    } cleave %set-string-nth-fast ;
+    { [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
 
 : dst/src ( insn -- dst src )
-    [ dst>> register ] [ src>> register ] bi ; inline
+    [ dst>> ] [ src>> ] bi ; inline
 
 : dst/src1/src2 ( insn -- dst src1 src2 )
-    [ dst>> register ]
-    [ src1>> register ]
-    [ src2>> ?register ] tri ; inline
+    [ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
 
 M: ##add     generate-insn dst/src1/src2 %add     ;
 M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
@@ -191,7 +160,7 @@ M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
 M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
 
 : dst/src/temp ( insn -- dst src temp )
-    [ dst/src ] [ temp>> register ] bi ; inline
+    [ dst/src ] [ temp>> ] bi ; inline
 
 M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
 M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
@@ -222,7 +191,7 @@ M: ##alien-float      generate-insn dst/src %alien-float      ;
 M: ##alien-double     generate-insn dst/src %alien-double     ;
 
 : >alien-setter< ( insn -- src value )
-    [ src>> register ] [ value>> register ] bi ; inline
+    [ src>> ] [ value>> ] bi ; inline
 
 M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
 M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
@@ -233,23 +202,23 @@ M: ##set-alien-double    generate-insn >alien-setter< %set-alien-double    ;
 
 M: ##allot generate-insn
     {
-        [ dst>> register ]
+        [ dst>> ]
         [ size>> ]
         [ class>> ]
-        [ temp>> register ]
+        [ temp>> ]
     } cleave
     %allot ;
 
 M: ##write-barrier generate-insn
-    [ src>> register ]
-    [ card#>> register ]
-    [ table>> register ]
+    [ src>> ]
+    [ card#>> ]
+    [ table>> ]
     tri %write-barrier ;
 
 M: _gc generate-insn
     {
-        [ temp1>> register ]
-        [ temp2>> register ]
+        [ temp1>> ]
+        [ temp2>> ]
         [ gc-roots>> ]
         [ gc-root-count>> ]
     } cleave %gc ;
@@ -257,7 +226,7 @@ M: _gc generate-insn
 M: _loop-entry generate-insn drop %loop-entry ;
 
 M: ##alien-global generate-insn
-    [ dst>> register ] [ symbol>> ] [ library>> ] tri
+    [ dst>> ] [ symbol>> ] [ library>> ] tri
     %alien-global ;
 
 ! ##alien-invoke
@@ -370,7 +339,7 @@ M: long-long-type flatten-value-type ( type -- types )
 
 : objects>registers ( params -- )
     #! Generate code for unboxing a list of C types, then
-    #! generate code for moving these parameters to register on
+    #! generate code for moving these parameters to registers on
     #! architectures where parameters are passed in registers.
     [
         [ prepare-box-struct ] keep
@@ -499,11 +468,11 @@ M: _branch generate-insn
 
 : >compare< ( insn -- dst temp cc src1 src2 )
     {
-        [ dst>> register ]
-        [ temp>> register ]
+        [ dst>> ]
+        [ temp>> ]
         [ cc>> ]
-        [ src1>> register ]
-        [ src2>> ?register ]
+        [ src1>> ]
+        [ src2>> ]
     } cleave ; inline
 
 M: ##compare generate-insn >compare< %compare ;
@@ -514,8 +483,8 @@ M: ##compare-float generate-insn >compare< %compare-float ;
     {
         [ label>> lookup-label ]
         [ cc>> ]
-        [ src1>> register ]
-        [ src2>> ?register ]
+        [ src1>> ]
+        [ src2>> ]
     } cleave ; inline
 
 M: _compare-branch generate-insn

diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 649a72cd207130a546c6bdc6102fd390ae47817f..eb8c0fbf98199943d65b635b56f198d8861f7a77 100644 (file)
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -22,11 +22,11 @@ IN: compiler.tests.low-level-ir
         T{ ##inc-d f 1 }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##branch }
-    } append 1 test-bb
+    } [ clone ] map append 1 test-bb
     V{
         T{ ##epilogue }
         T{ ##return }
-    } 2 test-bb
+    } [ clone ] map 2 test-bb
     0 get 1 get 1vector >>successors drop
     1 get 2 get 1vector >>successors drop
     compile-test-cfg

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 55d4bc9be91130ebe7311e9f891c4448e574b887..17dbcf5c3cbb8b7a87e8df8d00cafe7de0801e07 100755 (executable)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -927,7 +927,7 @@ USE: arrays
 : array-flip ( matrix -- newmatrix )
     { array } declare
     [ dup first array-length [ array-length min ] reduce ] keep
-    [ [ array-nth ] with { } map-as ] curry { } map-as ;
+    [ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
 
 PRIVATE>