diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 7ea02c81e5..384fd65c1a 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 265cbb8f00..c3ae15f069 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -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 +: ( entry word label -- cfg ) f f cfg boa ; -TUPLE: mr { instructions array } word label spill-counts ; +TUPLE: mr { instructions array } word label ; : ( instructions word label -- mr ) mr new diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 65191d5ac2..bf5adc2d55 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -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 ; diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor index 5db760e861..68c89be455 100644 --- a/basis/compiler/cfg/dce/dce.factor +++ b/basis/compiler/cfg/dce/dce.factor @@ -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 ; \ No newline at end of file + [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ] + [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ] + [ ] + tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 6b0aba6813..5c106bfaee 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -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 -- ) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index ba2a4dac3a..17e49f59a8 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -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 ; diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index eed0aeb0b5..b91120ccfd 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 5682aa668d..d2d444a4a5 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 ; diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor index 876ac5596c..e8f8641e7d 100644 --- a/basis/compiler/cfg/instructions/syntax/syntax.factor +++ b/basis/compiler/cfg/instructions/syntax/syntax.factor @@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax "insn" "compiler.cfg.instructions" lookup ; : insn-effect ( word -- effect ) - boa-effect in>> but-last f ; + boa-effect in>> 2 head* f ; 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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index da45b45aaa..f21b9e5db8 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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 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 ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 4ddd1fdc0b..bfbc824846 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -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 ] [ diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 855f2a6648..1e6b9d02c8 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 1055a3524a..55bcdc7470 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -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 [ [ ] 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 ; diff --git a/basis/compiler/cfg/linear-scan/numbering/authors.txt b/basis/compiler/cfg/linear-scan/numbering/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/compiler/cfg/linear-scan/numbering/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor new file mode 100644 index 0000000000..6734f6a359 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor @@ -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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 9b328a43c0..5ad8be2953 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -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 ; + [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri + ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index e069caa03d..72609cf4d9 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -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' ) work-list set H{ } clone live-ins set H{ } clone phi-live-ins set H{ } clone live-outs set - add-to-work-list - work-list get [ liveness-step ] slurp-deque ; \ No newline at end of file + 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 ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index f59e9e0b83..8ceafd1693 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -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 ; diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor index d94e57f378..3ebf553a45 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -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 ; \ No newline at end of file +: eliminate-phis ( cfg -- cfg' ) + dup [ eliminate-phi-step ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor index 9bc3a08f63..5be085ba5a 100644 --- a/basis/compiler/cfg/predecessors/predecessors.factor +++ b/basis/compiler/cfg/predecessors/predecessors.factor @@ -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 ; diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor index babea55643..d01f5ee864 100644 --- a/basis/compiler/cfg/rpo/rpo.factor +++ b/basis/compiler/cfg/rpo/rpo.factor @@ -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 + [ >>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 dup number-blocks - ] with-variable ; inline + post-order ; 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 ; \ No newline at end of file + [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index e846ebc28f..bd0e539173 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -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 diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index ffff728ece..955630a76d 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -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 ; diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index dabecaeec4..d5fb1e56cf 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -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 ; diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor index ebc333b537..1d14cef193 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor index b6ec1a72ce..91c337e43a 100644 --- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor +++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor @@ -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 ; diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index 990543ed7a..c53a001d28 100644 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -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 ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index c771d3b388..cc62c0f0c1 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -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 ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index e4767599a7..52d5170138 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -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 ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index c3d70fdc5b..ae58c3bd3e 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -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