diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 42655aceb8..cdec87b61d 100644 --- 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> : ( 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 b4c7223435..08c43f203c 100644 --- 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 8618932e14..e5583a14ab 100644 --- 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. swap [ instructions>> clone-instructions >>instructions ] diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 066d20ddec..e08b3b25bb 100644 --- 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 -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 e8f8641e7d..ab1c9599e5 100644 --- 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 ; + boa-effect in>> but-last f ; 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 3664f58b1e..071118d60f 100644 --- 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 -- ) - pending-intervals set + pending-interval-heap set + H{ } clone pending-interval-assoc set 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 ; +: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ; -: all-vregs ( insn -- vregs ) - [ [ temp-vregs ] [ uses-vregs ] bi append ] - [ defs-vreg ] bi - [ suffix ] when* ; - -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 [ ] 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 ] 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 7362d185b4..1673b1b365 100644 --- 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 68f7544e8e..b1b44cde44 100644 --- 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 cc148d34d8..97fb3205c2 100755 --- 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 index 0000000000..c09c2969ba --- /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 + +> 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>> [ process-successor ] each ] + } cleave ; + +PRIVATE> + +: linearization-order ( cfg -- bbs ) + ! We call 'post-order drop' to ensure blocks receive their + ! RPO numbers. + 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 2a9d8d4911..ffb824f093 100644 --- 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 9de3fdd8d8..3d032f7510 100644 --- 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 3bbbb887f0..d2c7698999 100644 --- 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 d242d5d90d..f01b10f6eb 100644 --- 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 993edbf812..f9a4786eb5 100755 --- 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 649a72cd20..eb8c0fbf98 100644 --- 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 55d4bc9be9..17dbcf5c3c 100755 --- 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>