Merge branch 'master' of git://factorcode.org/git/factor
commit
c54189ce19
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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 ]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
: 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 [ <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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
[
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
||||
SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ;
|
|
@ -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 ;
|
||||
RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]
|
||||
|
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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>
|
||||
|
||||
|
|
Loading…
Reference in New Issue