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 ;
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
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
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 ;
! 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
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
: 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 -- )
-! 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 ;
! 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
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 ;
-! 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
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 ;
"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 ;
] [ 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 ;
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
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 ] [
-! 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 ;
! 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 ;
-! 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
[ [ <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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
[ 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> ;
! 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
[ ##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>>
[ 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 ;
\ 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
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 ;
! 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 -- )
[ [ 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
: 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 ;
] [ , ] 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 ;
\ No newline at end of file
+ [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
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>>
[
[ ##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
[ ] [ [ [ 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
! 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= ]
] 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= ]
! 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
] 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 ;
-! 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
! 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 ;
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 ;
[ [ 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
[ 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 ] [
: 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 ;
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 ;
: 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 -- ? )
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
: 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 ;
! 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
: 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 ;
! 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.
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
-: eliminate-write-barriers ( rpo -- )
+: eliminate-write-barriers ( cfg -- cfg' )
[ drop ] [ write-barriers-step ] local-optimization ;
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
: backend ( nodes word -- )
build-cfg [
optimize-cfg
- build-mr
convert-two-operand
linear-scan
+ build-mr
build-stack-frame
generate
save-asm