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

Various codegen improvements: 

- new-insn word to construct instructions
- cache RPO in the CFG
- re-organize low-level optimizer so that MR is built after register allocation
- register allocation now stores instruction numbers in the instructions themselves
- split defs-vregs into defs-vregs and temp-vregs
db4
Slava Pestov 2009-05-29 13:11:34 -05:00
parent 280736ab00
commit e04df76f60
30 changed files with 258 additions and 204 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -227,7 +227,7 @@ M: ##read analyze-aliases*
call-next-method
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
2dup live-slot dup [
2nip f \ ##copy boa analyze-aliases* nip
2nip \ ##copy new-insn analyze-aliases* nip
] [
drop remember-slot
] if ;
@ -284,5 +284,5 @@ M: insn eliminate-dead-stores* ;
compute-live-stores
eliminate-dead-stores ;
: alias-analysis ( rpo -- )
: alias-analysis ( cfg -- cfg' )
[ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;

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

@ -27,11 +27,11 @@ M: basic-block hashcode* nip id>> ;
building get push
] with-variable ; inline
TUPLE: cfg { entry basic-block } word label ;
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
C: <cfg> cfg
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
TUPLE: mr { instructions array } word label spill-counts ;
TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )
mr new

14
basis/compiler/cfg/checker/checker.factor
View File

@ -41,20 +41,18 @@ ERROR: bad-successors ;
ERROR: bad-live-in ;
: check-rpo ( rpo -- )
[ compute-liveness ]
[ first live-in assoc-empty? [ bad-live-in ] unless ]
[ [ check-basic-block ] each ]
tri ;
ERROR: undefined-values uses defs ;
: check-mr ( mr -- )
! Check that every used register has a definition
instructions>>
[ [ uses-vregs ] map concat ]
[ [ defs-vregs ] map concat ] bi
[ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- )
[ reverse-post-order check-rpo ] [ build-mr check-mr ] bi ;
compute-liveness
[ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
[ [ check-basic-block ] each-basic-block ]
[ build-mr check-mr ]
tri ;

12
basis/compiler/cfg/dce/dce.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use ;
compiler.cfg.instructions compiler.cfg.def-use
compiler.cfg.rpo ;
IN: compiler.cfg.dce
! Maps vregs to sequences of vregs
@ -36,8 +37,9 @@ M: ##flushable live-insn? dst>> live-vregs get key? ;
M: insn live-insn? drop t ;
: eliminate-dead-code ( rpo -- )
: eliminate-dead-code ( cfg -- cfg' )
init-dead-code
[ [ instructions>> [ update-liveness-graph ] each ] each ]
[ [ [ [ live-insn? ] filter ] change-instructions drop ] each ]
bi ;
[ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
[ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
[ ]
tri ;

6
basis/compiler/cfg/debugger/debugger.factor
View File

@ -23,10 +23,10 @@ SYMBOL: allocate-registers?
: test-mr ( quot -- mrs )
test-cfg [
optimize-cfg
build-mr
convert-two-operand
allocate-registers? get
[ linear-scan build-stack-frame ] when
allocate-registers? get [ linear-scan ] when
build-mr
allocate-registers? get [ build-stack-frame ] when
] map ;
: insn. ( insn -- )

40
basis/compiler/cfg/def-use/def-use.factor
View File

@ -1,29 +1,39 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ;
M: ##allot defs-vregs dst/tmp-vregs ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##unary/temp defs-vregs dst>> 1array ;
M: ##allot defs-vregs dst>> 1array ;
M: ##slot defs-vregs dst>> 1array ;
M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ;
M: ##set-string-nth-fast defs-vregs temp>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ;
M: ##compare-imm defs-vregs dst/tmp-vregs ;
M: ##compare-float defs-vregs dst/tmp-vregs ;
M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst>> 1array ;
M: ##compare defs-vregs dst>> 1array ;
M: ##compare-imm defs-vregs dst>> 1array ;
M: ##compare-float defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp temp-vregs temp>> 1array ;
M: ##allot temp-vregs temp>> 1array ;
M: ##dispatch temp-vregs temp>> 1array ;
M: ##slot temp-vregs temp>> 1array ;
M: ##set-slot temp-vregs temp>> 1array ;
M: ##string-nth temp-vregs temp>> 1array ;
M: ##set-string-nth-fast temp-vregs temp>> 1array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
M: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ;

8
basis/compiler/cfg/height/height.factor
View File

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

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

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.algebra alien byte-arrays
@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;

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>> but-last f <effect> ;
boa-effect in>> 2 head* f <effect> ;
SYNTAX: INSN:
parse-tuple-definition "regs" suffix
parse-tuple-definition { "regs" "insn#" } append
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
[ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ;

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

@ -59,29 +59,35 @@ SYMBOL: unhandled-intervals
] [ 2drop ] if
] if ;
GENERIC: (assign-registers) ( insn -- )
GENERIC: assign-registers-in-insn ( insn -- )
M: vreg-insn (assign-registers)
dup
[ defs-vregs ] [ uses-vregs ] bi append
active-intervals get swap '[ vreg>> _ member? ] filter
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
M: vreg-insn assign-registers-in-insn
active-intervals get over all-vregs '[ vreg>> _ member? ] filter
[ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
>>regs drop ;
M: insn (assign-registers) drop ;
M: insn assign-registers-in-insn drop ;
: init-assignment ( live-intervals -- )
V{ } clone active-intervals set
<min-heap> unhandled-intervals set
init-unhandled ;
: assign-registers ( insns live-intervals -- insns' )
: assign-registers-in-block ( bb -- )
[
init-assignment
[
[ activate-new-intervals ]
[ drop [ (assign-registers) ] [ , ] bi ]
[ expire-old-intervals ]
tri
] each-index
] { } make ;
[
[ insn#>> activate-new-intervals ]
[ [ assign-registers-in-insn ] [ , ] bi ]
[ insn#>> expire-old-intervals ]
tri
] each
] V{ } make
] change-instructions drop ;
: assign-registers ( rpo live-intervals -- )
init-assignment
[ assign-registers-in-block ] each ;

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

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

17
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces make
cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.assignment ;
@ -23,16 +25,13 @@ IN: compiler.cfg.linear-scan
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
: (linear-scan) ( insns -- insns' )
: (linear-scan) ( rpo -- )
dup number-instructions
dup compute-live-intervals
machine-registers allocate-registers assign-registers ;
: linear-scan ( mr -- mr' )
: linear-scan ( cfg -- cfg' )
[
[
[
(linear-scan) %
spill-counts get _spill-counts
] { } make
] change-instructions
dup reverse-post-order (linear-scan)
spill-counts get >>spill-counts
] with-scope ;

18
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

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

1
basis/compiler/cfg/linear-scan/numbering/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

11
basis/compiler/cfg/linear-scan/numbering/numbering.factor Normal file
View File

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

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

@ -60,25 +60,31 @@ M: ##branch linearize-insn
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
: with-regs ( insn quot -- )
over regs>> [ call ] dip building get peek (>>regs) ; inline
M: ##compare-branch linearize-insn
binary-conditional _compare-branch emit-branch ;
[ binary-conditional _compare-branch ] with-regs emit-branch ;
M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ;
[ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
M: ##compare-float-branch linearize-insn
binary-conditional _compare-float-branch emit-branch ;
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
M: ##dispatch linearize-insn
swap
[ [ src>> ] [ temp>> ] bi _dispatch ]
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
: linearize-basic-blocks ( rpo -- insns )
[ [ linearize-basic-block ] each ] { } make ;
: linearize-basic-blocks ( cfg -- insns )
[
[ [ linearize-basic-block ] each-basic-block ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
: build-mr ( cfg -- mr )
[ reverse-post-order linearize-basic-blocks ]
[ word>> ] [ label>> ]
tri <mr> ;
[ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
<mr> ;

14
basis/compiler/cfg/liveness/liveness.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
dlists compiler.cfg.def-use compiler.cfg.instructions ;
dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo ;
IN: compiler.cfg.liveness
! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
@ -36,7 +37,7 @@ SYMBOL: work-list
[ ##phi? not ] filter [ uses-vregs ] map-unique ;
: kill-set ( instructions -- seq )
[ defs-vregs ] map-unique ;
[ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
: compute-live-in ( basic-block -- live-in )
dup instructions>>
@ -68,10 +69,13 @@ SYMBOL: work-list
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-liveness ( rpo -- )
: compute-liveness ( cfg -- cfg' )
<hashed-dlist> work-list set
H{ } clone live-ins set
H{ } clone phi-live-ins set
H{ } clone live-outs set
<reversed> add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
dup post-order add-to-work-list
work-list get [ liveness-step ] slurp-deque ;
: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
[ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ;

30
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -14,23 +14,17 @@ compiler.cfg.rpo
compiler.cfg.phi-elimination ;
IN: compiler.cfg.optimizer
: optimize-cfg ( cfg -- cfg )
: optimize-cfg ( cfg -- cfg' )
[
[
[ compute-predecessors ]
[ delete-useless-blocks ]
[ delete-useless-conditionals ] tri
] [
reverse-post-order
{
[ normalize-height ]
[ stack-analysis ]
[ compute-liveness ]
[ alias-analysis ]
[ value-numbering ]
[ eliminate-dead-code ]
[ eliminate-write-barriers ]
[ eliminate-phis ]
} cleave
] [ ] tri
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
stack-analysis
compute-liveness
alias-analysis
value-numbering
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
] with-scope ;

8
basis/compiler/cfg/phi-elimination/phi-elimination.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler.cfg compiler.cfg.instructions fry
kernel sequences ;
USING: accessors compiler.cfg compiler.cfg.instructions
compiler.cfg.rpo fry kernel sequences ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
@ -17,5 +17,5 @@ IN: compiler.cfg.phi-elimination
[ [ eliminate-phi ] with each ] dip
] change-instructions drop ;
: eliminate-phis ( rpo -- )
[ eliminate-phi-step ] each ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block ;

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

@ -6,5 +6,5 @@ IN: compiler.cfg.predecessors
: predecessors-step ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: compute-predecessors ( cfg -- )
[ predecessors-step ] each-basic-block ;
: compute-predecessors ( cfg -- cfg' )
dup [ predecessors-step ] each-basic-block ;

24
basis/compiler/cfg/rpo/rpo.factor
View File

@ -16,22 +16,24 @@ SYMBOL: visited
] [ , ] bi
] if ;
: post-order ( cfg -- blocks )
[ entry>> post-order-traversal ] { } make ;
: number-blocks ( blocks -- )
[ >>number drop ] each-index ;
dup length iota <reversed>
[ >>number drop ] 2each ;
: post-order ( cfg -- blocks )
dup post-order>> [ ] [
[
H{ } clone visited set
dup entry>> post-order-traversal
] { } make dup number-blocks
>>post-order post-order>>
] ?if ;
: reverse-post-order ( cfg -- blocks )
H{ } clone visited [
post-order <reversed> dup number-blocks
] with-variable ; inline
post-order <reversed> ; inline
: each-basic-block ( cfg quot -- )
[ reverse-post-order ] dip each ; inline
: optimize-basic-block ( bb init-quot insn-quot -- )
[ '[ live-in keys _ call ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
: local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- )
'[ _ _ optimize-basic-block ] each ;
[ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline

46
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -8,7 +8,7 @@ sets ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
: check-for-redundant-ops ( rpo -- )
: check-for-redundant-ops ( cfg -- )
[
instructions>>
[
@ -18,34 +18,36 @@ IN: compiler.cfg.stack-analysis.tests
[ ##replace? ] filter [ loc>> ] map duplicates empty?
[ "Redundant replaces" throw ] unless
] bi
] each ;
] each-basic-block ;
: test-stack-analysis ( quot -- mr )
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
dup compute-predecessors
dup delete-useless-blocks
dup delete-useless-conditionals
reverse-post-order
dup normalize-height
dup stack-analysis
dup check-rpo
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
normalize-height
stack-analysis
dup check-cfg
dup check-for-redundant-ops ;
: linearize ( cfg -- mr )
build-mr instructions>> ;
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##peek? ] count ] unit-test
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
! Redundant replace is redundant
[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Replace required here
[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Only one replace, at the end
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
! Do we support the full language?
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
@ -63,10 +65,10 @@ IN: compiler.cfg.stack-analysis.tests
[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
! This should be a total no-op
[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Don't insert inc-d/inc-r; that's wrong!
[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test
[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
! Bug in height tracking
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
@ -81,13 +83,13 @@ IN: compiler.cfg.stack-analysis.tests
! Make sure the replace stores a value with the right height
[ ] [
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
[ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
] unit-test
! translate-loc was the wrong way round
[ ] [
[ 1 2 rot ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
[ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 3 assert= ]
@ -95,7 +97,7 @@ IN: compiler.cfg.stack-analysis.tests
] unit-test
[ ] [
[ 1 2 ? ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
[ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 1 assert= ]
@ -105,6 +107,6 @@ IN: compiler.cfg.stack-analysis.tests
! Sync before a back-edge, not after
! ##peeks should be inserted before a ##loop-entry
[ 1 ] [
[ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ ##add-imm? ] count
] unit-test

4
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -278,10 +278,10 @@ ERROR: cannot-merge-poisoned states ;
] 2bi
] V{ } make >>instructions drop ;
: stack-analysis ( rpo -- )
: stack-analysis ( cfg -- cfg' )
[
H{ } clone copies set
H{ } clone state-in set
H{ } clone state-out set
[ visit-block ] each
dup [ visit-block ] each-basic-block
] with-scope ;

46
basis/compiler/cfg/two-operand/two-operand.factor
View File

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

2
basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
View File

@ -7,5 +7,5 @@ compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
[ [ drop 1 ] unless ]
} [
[ [ ] ] dip
'[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test
'[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
] each

16
basis/compiler/cfg/useless-blocks/useless-blocks.factor
View File

@ -35,10 +35,11 @@ IN: compiler.cfg.useless-blocks
[ instructions>> first ##branch? ]
} 1&& ;
: delete-useless-blocks ( cfg -- )
[
: delete-useless-blocks ( cfg -- cfg' )
dup [
dup delete-basic-block? [ delete-basic-block ] [ drop ] if
] each-basic-block ;
] each-basic-block
f >>post-order ;
: delete-conditional? ( bb -- ? )
dup instructions>> [ drop f ] [
@ -51,10 +52,11 @@ IN: compiler.cfg.useless-blocks
: delete-conditional ( bb -- )
dup successors>> first 1vector >>successors
[ but-last f \ ##branch boa suffix ] change-instructions
[ but-last \ ##branch new-insn suffix ] change-instructions
drop ;
: delete-useless-conditionals ( cfg -- )
[
: delete-useless-conditionals ( cfg -- cfg' )
dup [
dup delete-conditional? [ delete-conditional ] [ drop ] if
] each-basic-block ;
] each-basic-block
f >>post-order ;

18
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
M: ##mul-imm rewrite
dup src2>> dup power-of-2? [
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
[ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
dup number-values
] [ drop ] if ;
@ -36,9 +36,9 @@ M: ##mul-imm rewrite
: rewrite-boolean-comparison ( expr -- insn )
src1>> vreg>expr dup op>> {
{ \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
{ \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
{ \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
{ \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
{ \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
} case ;
: tag-fixnum-expr? ( expr -- ? )
@ -60,11 +60,11 @@ M: ##mul-imm rewrite
GENERIC: rewrite-tagged-comparison ( insn -- insn' )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
M: ##compare-imm rewrite-tagged-comparison
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
i f \ ##compare-imm boa ;
i \ ##compare-imm new-insn ;
M: ##compare-imm-branch rewrite
dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@ -96,9 +96,9 @@ M: ##compare rewrite
: rewrite-redundant-comparison ( insn -- insn' )
[ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
{ \ ##compare [ >compare-expr< i f \ ##compare boa ] }
{ \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
{ \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
{ \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
{ \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
{ \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;

4
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.propagate
@ -21,5 +21,5 @@ IN: compiler.cfg.value-numbering
: value-numbering-step ( insns -- insns' )
[ [ number-values ] [ rewrite propagate ] bi ] map ;
: value-numbering ( rpo -- )
: value-numbering ( cfg -- cfg' )
[ init-value-numbering ] [ value-numbering-step ] local-optimization ;

4
basis/compiler/cfg/write-barrier/write-barrier.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.rpo ;
compiler.cfg.liveness ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
@ -42,5 +42,5 @@ M: insn eliminate-write-barrier ;
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
: eliminate-write-barriers ( rpo -- )
: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;

6
basis/compiler/compiler.factor
View File

@ -8,8 +8,8 @@ stack-checker.inlining stack-checker.errors combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
compiler.utilities ;
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.cfg.rpo
compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@ -146,9 +146,9 @@ t compile-dependencies? set-global
: backend ( nodes word -- )
build-cfg [
optimize-cfg
build-mr
convert-two-operand
linear-scan
build-mr
build-stack-frame
generate
save-asm