-! 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
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 )
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 )
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 ]
tri
] with-compilation-unit
+! Computing vreg -> insn -> bb mapping
SYMBOLS: defs insns ;
: def-of ( vreg -- node ) defs get at ;
-! 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
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 ;
: 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> ;
] unit-test
cfg new 8 >>spill-area-size cfg set
-H{ } clone spill-temps set
+init-resolve
[ t ] [
{
-! 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
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 , ;
: 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 ] [
: resolve-data-flow ( cfg -- )
needs-predecessors
-
- H{ } clone spill-temps set
+ init-resolve
[ resolve-block-data-flow ] each-basic-block ;
<PRIVATE
-SYMBOLS: temp locs preds to-do ready ;
+SYMBOLS: locs preds to-do ready ;
: init-to-do ( bs -- )
to-do get push-all-back ;
: 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 ;
-! 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
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 ;
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 -- )
-
-M: insn rename-insn-uses drop ;
+! Special rename-insn-uses methods
+M: ##parallel-copy rename-insn-uses
+ [ [ first2 USE-QUOT 2array ] map ] change-values ;
-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
USE-QUOT change-src call-next-method ;
M: ##callback-outputs rename-insn-uses
- [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs drop ;
-
-M: ##phi rename-insn-uses
- [ USE-QUOT assoc-map ] change-inputs drop ;
+ [ [ first3 USE-QUOT 2dip 3array ] map ] change-reg-inputs
+ drop ;
-GENERIC: rename-insn-temps ( insn -- )
+! 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
-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 ]
-! 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 ;
-! 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
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 ;
: 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 -- )
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 ;
+:: maybe-eliminate-copy ( vreg1 vreg2 -- )
+ ! Eliminate a copy if possible.
+ vreg1 vreg2 eq? [
+ vreg1 vreg2 vregs-interfere?
+ [ drop ] [ vreg1 vreg2 coalesce-vregs ] if
+ ] unless ;
+
: process-copies ( -- )
- copies get [ maybe-eliminate-copy ] assoc-each ;
+ copies get [ leaders maybe-eliminate-copy ] assoc-each ;
-GENERIC: useful-insn? ( insn -- ? )
+GENERIC: cleanup-insn ( insn -- )
: useful-copy? ( insn -- ? )
- [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
+ [ dst>> ] [ src>> ] bi leaders eq? not ; inline
+
+M: ##copy cleanup-insn
+ dup useful-copy? [ , ] [ drop ] if ;
-M: ##copy useful-insn? useful-copy? ;
+M: ##parallel-copy cleanup-insn
+ values>>
+ [ first2 leaders 2array ] map [ first2 eq? not ] filter
+ [ parallel-copy-rep ] unless-empty ;
-M: ##tagged>integer useful-insn? useful-copy? ;
+M: ##tagged>integer cleanup-insn
+ dup useful-copy? [ , ] [ drop ] if ;
-M: ##phi useful-insn? drop f ;
+M: ##phi cleanup-insn drop ;
-M: insn useful-insn? drop t ;
+M: insn cleanup-insn , ;
: cleanup-cfg ( cfg -- )
- [ [ useful-insn? ] filter! ] simple-optimization ;
+ [ [ [ cleanup-insn ] each ] V{ } make ] simple-optimization ;
PRIVATE>
dup compute-live-ranges
dup prepare-coalescing
process-copies
- dup cleanup-cfg ;
+ dup cleanup-cfg
+ dup compute-live-sets ;
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
projects / factor.git / commitdiff