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

View File

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

View File

@ -27,11 +27,11 @@ M: basic-block hashcode* nip id>> ;
building get push building get push
] with-variable ; inline ] 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> ( instructions word label -- mr )
mr new mr new

View File

@ -41,20 +41,18 @@ ERROR: bad-successors ;
ERROR: bad-live-in ; 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 ; ERROR: undefined-values uses defs ;
: check-mr ( mr -- ) : check-mr ( mr -- )
! Check that every used register has a definition ! Check that every used register has a definition
instructions>> instructions>>
[ [ uses-vregs ] map concat ] [ [ uses-vregs ] map concat ]
[ [ defs-vregs ] map concat ] bi [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
2dup subset? [ 2drop ] [ undefined-values ] if ; 2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- ) : 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 ;

View File

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

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel compiler.cfg.instructions ; USING: accessors arrays kernel compiler.cfg.instructions ;
IN: compiler.cfg.def-use IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq ) GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq )
: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
M: ##flushable defs-vregs dst>> 1array ; M: ##flushable defs-vregs dst>> 1array ;
M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp defs-vregs dst>> 1array ;
M: ##unary/temp defs-vregs dst/tmp-vregs ; M: ##allot defs-vregs dst>> 1array ;
M: ##allot defs-vregs dst/tmp-vregs ; M: ##slot defs-vregs dst>> 1array ;
M: ##dispatch defs-vregs temp>> 1array ;
M: ##slot defs-vregs dst/tmp-vregs ;
M: ##set-slot defs-vregs temp>> 1array ; M: ##set-slot defs-vregs temp>> 1array ;
M: ##string-nth defs-vregs dst/tmp-vregs ; M: ##string-nth defs-vregs dst>> 1array ;
M: ##set-string-nth-fast defs-vregs temp>> 1array ; M: ##compare defs-vregs dst>> 1array ;
M: ##compare defs-vregs dst/tmp-vregs ; M: ##compare-imm defs-vregs dst>> 1array ;
M: ##compare-imm defs-vregs dst/tmp-vregs ; M: ##compare-float defs-vregs dst>> 1array ;
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: insn defs-vregs drop f ; 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: ##unary uses-vregs src>> 1array ;
M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##binary-imm uses-vregs src1>> 1array ; M: ##binary-imm uses-vregs src1>> 1array ;

View File

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

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

View File

@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
"insn" "compiler.cfg.instructions" lookup ; "insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect ) : insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ; boa-effect in>> 2 head* f <effect> ;
SYNTAX: INSN: SYNTAX: INSN:
parse-tuple-definition "regs" suffix parse-tuple-definition { "regs" "insn#" } append
[ dup tuple eq? [ drop insn-word ] when ] dip [ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ] [ define-tuple-class ]
[ 2drop save-location ] [ 2drop save-location ]
[ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ] [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; 3tri ;

View File

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

View File

@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors kernel fry arrays splitting namespaces math accessors vectors
math.order grouping math.order grouping
cpu.architecture cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.registers
compiler.cfg.linear-scan compiler.cfg.linear-scan
@ -264,9 +266,15 @@ SYMBOL: max-uses
USING: math.private compiler.cfg.debugger ; 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 ] [ [ f ] [
T{ basic-block
{ instructions
V{
T{ ##allot T{ ##allot
f f
T{ vreg f int-regs 1 } T{ vreg f int-regs 1 }
@ -274,8 +282,11 @@ USING: math.private compiler.cfg.debugger ;
array array
T{ vreg f int-regs 2 } T{ vreg f int-regs 2 }
f f
} clone }
1array (linear-scan) first regs>> values all-equal? }
}
} clone [ [ clone ] map ] change-instructions
dup 1array (linear-scan) instructions>> first regs>> values all-equal?
] unit-test ] unit-test
[ 0 1 ] [ [ 0 1 ] [

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

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

View File

@ -0,0 +1 @@
Slava Pestov

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 ;

View File

@ -60,25 +60,31 @@ M: ##branch linearize-insn
[ drop dup successors>> second useless-branch? ] 2bi [ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; [ [ 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 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 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 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 M: ##dispatch linearize-insn
swap swap
[ [ src>> ] [ temp>> ] bi _dispatch ] [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
[ successors>> [ number>> _dispatch-label ] each ] [ successors>> [ number>> _dispatch-label ] each ]
bi* ; bi* ;
: linearize-basic-blocks ( rpo -- insns ) : linearize-basic-blocks ( cfg -- insns )
[ [ linearize-basic-block ] each ] { } make ; [
[ [ linearize-basic-block ] each-basic-block ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
: build-mr ( cfg -- mr ) : build-mr ( cfg -- mr )
[ reverse-post-order linearize-basic-blocks ] [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
[ word>> ] [ label>> ] <mr> ;
tri <mr> ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel sequences compiler.utilities USING: accessors arrays kernel sequences make compiler.cfg.instructions
compiler.cfg.instructions cpu.architecture ; compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y ! 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 ! has a LEA instruction which is effectively a three-operand
! addition ! 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 ) : convert-two-operand/integer ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy ] [ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
: convert-two-operand/float ( insn -- insns ) : convert-two-operand/float ( insn -- insns )
[ [ dst>> ] [ src1>> ] bi make-copy/float ] [ [ dst>> ] [ src1>> ] bi ##copy-float ]
[ dup dst>> >>src1 ] [ dup dst>> >>src1 , ]
bi 2array ; inline bi ; inline
GENERIC: convert-two-operand* ( insn -- insns ) GENERIC: convert-two-operand* ( insn -- )
M: ##not convert-two-operand* M: ##not convert-two-operand*
[ [ dst>> ] [ src>> ] bi make-copy ] [ [ dst>> ] [ src>> ] bi ##copy ]
[ dup dst>> >>src ] [ dup dst>> >>src , ]
bi 2array ; bi ;
M: ##sub convert-two-operand* convert-two-operand/integer ; M: ##sub convert-two-operand* convert-two-operand/integer ;
M: ##mul 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: ##mul-float convert-two-operand* convert-two-operand/float ;
M: ##div-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' ) : convert-two-operand ( cfg -- cfg' )
[
two-operand? [ two-operand? [
[ convert-two-operand* ] map-flat dup [
] when [
] change-instructions ; [ [ convert-two-operand* ] each ] V{ } make
] change-instructions drop
] each-basic-block
] when ;

View File

@ -7,5 +7,5 @@ compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
[ [ drop 1 ] unless ] [ [ drop 1 ] unless ]
} [ } [
[ [ ] ] dip [ [ ] ] 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 ] each

View File

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

View File

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

View File

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

View File

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

View File

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