Slava Pestov 2011-01-17 15:16:17 -08:00 committed by Doug Coleman
parent ae276ec225
commit 07227f22f9
10 changed files with 240 additions and 118 deletions

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
! Copyright (C) 2008, 2011 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs arrays classes combinators
compiler.units fry generalizations sequences.generalizations
@ -9,6 +9,9 @@ FROM: namespaces => set ;
FROM: sets => members ;
IN: compiler.cfg.def-use
! Utilities for iterating over instruction operands
! Def-use protocol
GENERIC: defs-vregs ( insn -- seq )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
@ -17,6 +20,52 @@ M: insn defs-vregs drop { } ;
M: insn temp-vregs drop { } ;
M: insn uses-vregs drop { } ;
! Instructions with unusual operands, also see these passes
! for special behavior:
! - compiler.cfg.renaming.functor
! - compiler.cfg.representations.preferred
CONSTANT: special-vreg-insns {
##parallel-copy
##phi
##alien-invoke
##alien-indirect
##alien-assembly
##callback-inputs
##callback-outputs
}
! Special defs-vregs methods
M: ##parallel-copy defs-vregs values>> [ first ] map ;
M: ##phi defs-vregs dst>> 1array ;
M: alien-call-insn defs-vregs
reg-outputs>> [ first ] map ;
M: ##callback-inputs defs-vregs
[ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
M: ##callback-outputs defs-vregs drop { } ;
! Special uses-vregs methods
M: ##parallel-copy uses-vregs values>> [ second ] map ;
M: ##phi uses-vregs inputs>> values ;
M: alien-call-insn uses-vregs
[ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
M: ##alien-indirect uses-vregs
[ call-next-method ] [ src>> ] bi prefix ;
M: ##callback-inputs uses-vregs
drop { } ;
M: ##callback-outputs uses-vregs
reg-inputs>> [ first ] map ;
! Generate defs-vregs, uses-vregs and temp-vregs for everything
! else
<PRIVATE
: slot-array-quot ( slots -- quot )
@ -45,33 +94,6 @@ M: insn uses-vregs drop { } ;
PRIVATE>
CONSTANT: special-vreg-insns
{ ##phi ##alien-invoke ##alien-indirect ##alien-assembly ##callback-inputs ##callback-outputs }
M: ##phi defs-vregs dst>> 1array ;
M: alien-call-insn defs-vregs
reg-outputs>> [ first ] map ;
M: ##callback-inputs defs-vregs
[ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
M: ##callback-outputs defs-vregs drop { } ;
M: ##phi uses-vregs inputs>> values ;
M: alien-call-insn uses-vregs
[ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
M: ##alien-indirect uses-vregs
[ call-next-method ] [ src>> ] bi prefix ;
M: ##callback-inputs uses-vregs
drop { } ;
M: ##callback-outputs uses-vregs
reg-inputs>> [ first ] map ;
[
insn-classes get
[ special-vreg-insns diff [ define-defs-vregs-method ] each ]
@ -80,6 +102,7 @@ M: ##callback-outputs uses-vregs
tri
] with-compilation-unit
! Computing vreg -> insn -> bb mapping
SYMBOLS: defs insns ;
: def-of ( vreg -- node ) defs get at ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! Copyright (C) 2008, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
math math.order layouts classes.union compiler.units alien
@ -119,6 +119,10 @@ def: dst
use: src
literal: rep ;
! Only used by compiler.cfg.cssa
FLUSHABLE-INSN: ##parallel-copy
literal: values ;
FOLDABLE-INSN: ##tagged>integer
def: dst/int-rep
use: src/tagged-rep ;

View File

@ -119,7 +119,7 @@ SYMBOL: unhandled-intervals
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
: next-spill-slot ( size -- n )
: next-spill-slot ( size -- spill-slot )
cfg get
[ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
<spill-slot> ;

View File

@ -107,7 +107,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
] unit-test
cfg new 8 >>spill-area-size cfg set
H{ } clone spill-temps set
init-resolve
[ t ] [
{

View File

@ -1,4 +1,4 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! Copyright (C) 2009, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals namespaces
@ -33,10 +33,21 @@ M: location equal?
M: location hashcode*
reg>> hashcode* ;
SYMBOL: spill-temps
SYMBOL: temp-spills
: spill-temp ( rep -- n )
rep-size spill-temps get [ next-spill-slot ] cache ;
: temp-spill ( rep -- spill-slot )
rep-size temp-spills get
[ next-spill-slot ] cache ;
SYMBOL: temp-locations
: temp-location ( loc -- temp )
rep>> temp-locations get
[ [ temp-spill ] keep <location> ] cache ;
: init-resolve ( -- )
H{ } clone temp-spills set
H{ } clone temp-locations set ;
: add-mapping ( from to rep -- )
'[ _ <location> ] bi@ 2array , ;
@ -74,20 +85,18 @@ SYMBOL: spill-temps
: register->register ( from to -- )
swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy, ;
SYMBOL: temp
: >insn ( from to -- )
{
{ [ over temp eq? ] [ temp->register ] }
{ [ dup temp eq? ] [ register->temp ] }
{ [ over reg>> spill-slot? ] [ memory->register ] }
{ [ dup reg>> spill-slot? ] [ register->memory ] }
[ register->register ]
} cond ;
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as
[ temp [ swap >insn ] parallel-mapping ##branch, ] { } make ;
[ swap ] H{ } assoc-map-as [
[ temp-location ] [ swap >insn ] parallel-mapping
##branch
] { } make ;
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
@ -105,6 +114,5 @@ SYMBOL: temp
: resolve-data-flow ( cfg -- )
needs-predecessors
H{ } clone spill-temps set
init-resolve
[ resolve-block-data-flow ] each-basic-block ;

View File

@ -11,7 +11,7 @@ IN: compiler.cfg.parallel-copy
<PRIVATE
SYMBOLS: temp locs preds to-do ready ;
SYMBOLS: locs preds to-do ready ;
: init-to-do ( bs -- )
to-do get push-all-back ;
@ -19,43 +19,59 @@ SYMBOLS: temp locs preds to-do ready ;
: init-ready ( bs -- )
locs get '[ _ key? not ] filter ready get push-all-front ;
: init ( mapping temp -- )
temp set
: init ( mapping -- )
<dlist> to-do set
<dlist> ready set
[ preds set ]
[ [ nip dup ] H{ } assoc-map-as locs set ]
[ keys [ init-to-do ] [ init-ready ] bi ] tri ;
:: process-ready ( b quot -- )
:: process-ready ( b quot: ( dst src -- ) -- )
b preds get at :> a
a locs get at :> c
b c quot call
b a locs get set-at
a c = a preds get at and [ a ready get push-front ] when ; inline
:: process-to-do ( b quot -- )
:: process-to-do ( b temp: ( src -- dst ) quot: ( dst src -- ) -- )
! Note that we check if b = loc(b), not b = loc(pred(b)) as the
! paper suggests. Confirmed by one of the authors at
! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f
b locs get at b = [
temp get b quot call
temp get b locs get set-at
b temp call :> temp
temp b quot call
temp b locs get set-at
b ready get push-front
] when ; inline
PRIVATE>
:: parallel-mapping ( mapping temp quot -- )
:: parallel-mapping ( mapping temp: ( src -- dst ) quot: ( dst src -- ) -- )
! mapping is a list of { dst src } pairs
[
mapping temp init
mapping init
to-do get [
ready get [
quot process-ready
] slurp-deque
quot process-to-do
temp quot process-to-do
] slurp-deque
] with-scope ; inline
: parallel-copy ( mapping -- )
next-vreg [ any-rep ##copy, ] parallel-mapping ;
! mapping is a list of { dst src } pairs
next-vreg '[ drop _ ] [ any-rep ##copy ] parallel-mapping ;
<PRIVATE
SYMBOL: temp-vregs
: temp-vreg ( rep -- vreg )
temp-vregs get [ next-vreg-rep ] cache ;
PRIVATE>
: parallel-copy-rep ( mapping -- )
! mapping is a list of { dst src } pairs
H{ } clone temp-vregs set
[ rep-of temp-vreg ] [ dup rep-of ##copy ] parallel-mapping ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! Copyright (C) 2009, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry functors generic.parser
kernel lexer namespaces parser sequences slots words sets
@ -6,6 +6,8 @@ compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.renaming.functor
! Like compiler.cfg.def-use, but for changing operands
: slot-change-quot ( slots quot -- quot' )
'[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
[ drop ] append ;
@ -19,34 +21,36 @@ rename-insn-temps DEFINES ${NAME}-insn-temps
WHERE
GENERIC: rename-insn-defs ( insn -- )
GENERIC: rename-insn-uses ( insn -- )
GENERIC: rename-insn-temps ( insn -- )
M: insn rename-insn-defs drop ;
M: insn rename-insn-uses drop ;
M: insn rename-insn-temps drop ;
insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
[ \ rename-insn-defs create-method-in ]
[ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
define
] each
! Instructions with unusual operands
! Special rename-insn-defs methods
M: ##parallel-copy rename-insn-defs
[ [ first2 [ DEF-QUOT ] dip 2array ] map ] change-values ;
M: ##phi rename-insn-defs DEF-QUOT change-dst drop ;
M: alien-call-insn rename-insn-defs
[ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs drop ;
[ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
drop ;
M: ##callback-inputs rename-insn-defs
[ [ first3 DEF-QUOT 2dip 3array ] map ] change-reg-outputs
[ [ first3 DEF-QUOT 2dip 3array ] map ] change-stack-outputs
drop ;
GENERIC: rename-insn-uses ( insn -- )
! Special rename-insn-uses methods
M: ##parallel-copy rename-insn-uses
[ [ first2 USE-QUOT 2array ] map ] change-values ;
M: insn rename-insn-uses drop ;
insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
] each
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs drop ;
M: alien-call-insn rename-insn-uses
[ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
@ -57,14 +61,21 @@ M: ##alien-indirect rename-insn-uses
USE-QUOT change-src call-next-method ;
M: ##callback-outputs rename-insn-uses
[ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
[ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
drop ;
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs drop ;
! Generate methods for everything else
insn-classes get special-vreg-insns diff [ insn-def-slots empty? not ] filter [
[ \ rename-insn-defs create-method-in ]
[ insn-def-slots [ name>> ] map DEF-QUOT slot-change-quot ] bi
define
] each
GENERIC: rename-insn-temps ( insn -- )
M: insn rename-insn-temps drop ;
insn-classes get special-vreg-insns diff [ insn-use-slots empty? not ] filter [
[ \ rename-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
define
] each
insn-classes get [ insn-temp-slots empty? not ] filter [
[ \ rename-insn-temps create-method-in ]

View File

@ -1,34 +1,54 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! Copyright (C) 2009, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel locals fry sequences sets
cpu.architecture
USING: accessors assocs kernel locals fry make namespaces
sequences cpu.architecture
compiler.cfg
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.predecessors
compiler.cfg.registers
compiler.cfg.instructions ;
FROM: assocs => change-at ;
IN: compiler.cfg.ssa.cssa
! Convert SSA to conventional SSA. This pass runs after representation
! selection, so it must keep track of representations when introducing
! new values.
: insert-copy? ( bb vreg -- ? )
! If the last instruction defines a value (which means it is
! ##fixnum-add, ##fixnum-sub or ##fixnum-mul) then we don't
! need to insert a copy since in fact doing so will result
! in incorrect code.
[ instructions>> last defs-vregs ] dip swap in? not ;
SYMBOL: copies
:: insert-copy ( bb src rep -- bb dst )
bb src insert-copy? [
rep next-vreg-rep :> dst
bb [ dst src rep ##copy, ] add-instructions
bb dst
] [ bb src ] if ;
: init-copies ( bb -- )
predecessors>> [ V{ } clone ] H{ } map>assoc copies set ;
: convert-phi ( ##phi -- )
dup dst>> rep-of '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
:: convert-operand ( src pred rep -- dst )
rep next-vreg-rep :> dst
{ dst src } pred copies get at push
dst ;
:: convert-phi ( insn preds -- )
insn dst>> rep-of :> rep
insn inputs>> :> inputs
preds [| pred |
pred inputs [ pred rep convert-operand ] change-at
] each ;
: insert-edge-copies ( from to copies -- )
[ ##parallel-copy ##branch ] { } make insert-basic-block ;
: insert-copies ( bb -- )
[ copies get ] dip '[
[ drop ] [ [ _ ] dip insert-edge-copies ] if-empty
] assoc-each ;
: convert-phis ( bb -- )
[ init-copies ]
[ dup predecessors>> '[ _ convert-phi ] each-phi ]
[ insert-copies ]
tri ;
: construct-cssa ( cfg -- )
[ [ convert-phi ] each-phi ] each-basic-block ;
needs-predecessors
dup [ convert-phis ] each-basic-block
cfg-changed drop ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! Copyright (C) 2009, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry locals kernel namespaces
sequences sequences.deep
USING: accessors arrays assocs fry locals kernel make
namespaces sequences sequences.deep
sets vectors
cpu.architecture
compiler.cfg.rpo
@ -13,6 +13,7 @@ compiler.cfg.liveness
compiler.cfg.ssa.cssa
compiler.cfg.ssa.interference
compiler.cfg.ssa.interference.live-ranges
compiler.cfg.parallel-copy
compiler.cfg.utilities
compiler.utilities ;
FROM: namespaces => set ;
@ -66,15 +67,6 @@ SYMBOL: copies
: coalesce-vregs ( merged leader1 leader2 -- )
[ coalesce-leaders ] [ coalesce-elements ] 2bi ;
:: maybe-eliminate-copy ( vreg1 vreg2 -- )
! Eliminate a copy of possible.
vreg1 leader :> vreg1
vreg2 leader :> vreg2
vreg1 vreg2 eq? [
vreg1 class-elements vreg2 class-elements sets-interfere?
[ drop ] [ vreg1 vreg2 coalesce-vregs ] if
] unless ;
GENERIC: prepare-insn ( insn -- )
: maybe-eliminate-copy-later ( dst src -- )
@ -96,35 +88,69 @@ M: vreg-insn prepare-insn
M: ##copy prepare-insn
[ dst>> ] [ src>> ] bi maybe-eliminate-copy-later ;
M: ##parallel-copy prepare-insn
values>> [ first2 maybe-eliminate-copy-later ] each ;
: leaders ( vreg1 vreg2 -- vreg1' vreg2' )
[ leader ] bi@ ;
: vregs-interfere? ( vreg1 vreg2 -- merged/f ? )
[ class-elements ] bi@ sets-interfere? ;
ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
:: must-eliminate-copy ( vreg1 vreg2 -- )
! Eliminate a copy.
vreg1 vreg2 eq? [
vreg1 vreg2 vregs-interfere?
[ vreg1 vreg2 vregs-shouldn't-interfere ]
[ vreg1 vreg2 coalesce-vregs ]
if
] unless ;
M: ##tagged>integer prepare-insn
[ dst>> ] [ src>> ] bi maybe-eliminate-copy ;
[ dst>> ] [ src>> ] bi leaders must-eliminate-copy ;
M: ##phi prepare-insn
[ dst>> ] [ inputs>> values ] bi
[ maybe-eliminate-copy ] with each ;
[ leaders must-eliminate-copy ] with each ;
: prepare-coalescing ( cfg -- )
init-coalescing
[ [ prepare-insn ] each ] simple-analysis ;
: process-copies ( -- )
copies get [ maybe-eliminate-copy ] assoc-each ;
:: maybe-eliminate-copy ( vreg1 vreg2 -- )
! Eliminate a copy if possible.
vreg1 vreg2 eq? [
vreg1 vreg2 vregs-interfere?
[ drop ] [ vreg1 vreg2 coalesce-vregs ] if
] unless ;
GENERIC: useful-insn? ( insn -- ? )
: process-copies ( -- )
copies get [ leaders maybe-eliminate-copy ] assoc-each ;
GENERIC: cleanup-insn ( insn -- )
: useful-copy? ( insn -- ? )
[ dst>> leader ] [ src>> leader ] bi eq? not ; inline
[ dst>> ] [ src>> ] bi leaders eq? not ; inline
M: ##copy useful-insn? useful-copy? ;
M: ##copy cleanup-insn
dup useful-copy? [ , ] [ drop ] if ;
M: ##tagged>integer useful-insn? useful-copy? ;
M: ##parallel-copy cleanup-insn
values>>
[ first2 leaders 2array ] map [ first2 eq? not ] filter
[ parallel-copy-rep ] unless-empty ;
M: ##phi useful-insn? drop f ;
M: ##tagged>integer cleanup-insn
dup useful-copy? [ , ] [ drop ] if ;
M: insn useful-insn? drop t ;
M: ##phi cleanup-insn drop ;
M: insn cleanup-insn , ;
: cleanup-cfg ( cfg -- )
[ [ useful-insn? ] filter! ] simple-optimization ;
[ [ [ cleanup-insn ] each ] V{ } make ] simple-optimization ;
PRIVATE>
@ -138,4 +164,5 @@ PRIVATE>
dup compute-live-ranges
dup prepare-coalescing
process-copies
dup cleanup-cfg ;
dup cleanup-cfg
dup compute-live-sets ;

View File

@ -524,3 +524,16 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
231 over 1 set-alien-unsigned-1 ;
[ B{ 123 231 } ] [ derived-pointer-test-1 ] unit-test
: fib-count2 ( -- x y ) 0 1 [ dup 4000000 <= ] [ [ + ] keep swap ] while ;
[ 3524578 5702887 ] [ fib-count2 ] unit-test
! Stupid repro
USE: compiler.cfg.registers
0 vreg-counter set-global
{ fib-count2 } compile
[ 3524578 5702887 ] [ fib-count2 ] unit-test