steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Sam Anklesaria 2009-07-29 15:51:33 -05:00
parent eb59431c3f cb7735ddf4
commit c54189ce19
17 changed files with 287 additions and 248 deletions

15
basis/bit-arrays/bit-arrays.factor
View File

@ -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 ;

3
basis/compiler/cfg/block-joining/block-joining.factor
View File

@ -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
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -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 ]

48
basis/compiler/cfg/instructions/instructions.factor
View File

@ -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

6
basis/compiler/cfg/instructions/syntax/syntax.factor
View File

@ -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 ;

90
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -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 ;

3
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -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
[

19
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -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

63
basis/compiler/cfg/linearization/linearization.factor
View File

@ -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 ;

73
basis/compiler/cfg/linearization/order/order.factor Normal file
View File

@ -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 ;

52
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -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 ;

51
basis/compiler/cfg/renaming/renaming.factor
View File

@ -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 ]

2
basis/compiler/cfg/ssa/construction/construction.factor
View File

@ -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 -- )

4
basis/compiler/cfg/utilities/utilities.factor
View File

@ -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

93
basis/compiler/codegen/codegen.factor
View File

@ -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

4
basis/compiler/tests/low-level-ir.factor
View File

@ -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

2
core/sequences/sequences.factor
View File

@ -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>