compiler.cfg.representations: new pass to make global unboxing decisions, relies on new compiler.cfg.loop-detection pass for loop nesting information
Slava Pestov
parent
926c46841b
commit
e21ca289c3
|
|
@ -56,8 +56,6 @@ IN: compiler.cfg.hats
|
|||
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
|
||||
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
|
||||
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
|
||||
: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
|
||||
: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
|
||||
: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
|
||||
: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
|
||||
: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
|
||||
|
|
|
|||
|
|
@ -250,6 +250,34 @@ UNION: kill-vreg-insn
|
|||
##alien-indirect
|
||||
##alien-callback ;
|
||||
|
||||
! Instructions that output floats
|
||||
UNION: output-float-insn
|
||||
##add-float
|
||||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##integer>float
|
||||
##unbox-float
|
||||
##alien-float
|
||||
##alien-double ;
|
||||
|
||||
! Instructions that take floats as inputs
|
||||
UNION: input-float-insn
|
||||
##add-float
|
||||
##sub-float
|
||||
##mul-float
|
||||
##div-float
|
||||
##float>integer
|
||||
##box-float
|
||||
##set-alien-float
|
||||
##set-alien-double
|
||||
##compare-float
|
||||
##compare-float-branch ;
|
||||
|
||||
! Smackdown
|
||||
INTERSECTION: ##unary-float ##unary input-float-insn ;
|
||||
INTERSECTION: ##binary-float ##binary input-float-insn ;
|
||||
|
||||
! Instructions that have complex expansions and require that the
|
||||
! output registers are not equal to any of the input registers
|
||||
UNION: def-is-use-insn
|
||||
|
|
|
|||
|
|
@ -53,7 +53,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
inline-alien ; inline
|
||||
|
||||
: inline-alien-float-setter ( node quot -- )
|
||||
'[ ds-pop ^^unbox-float @ ]
|
||||
'[ ds-pop @ ]
|
||||
[ float inline-alien-setter? ]
|
||||
inline-alien ; inline
|
||||
|
||||
|
|
@ -95,7 +95,7 @@ IN: compiler.cfg.intrinsics.alien
|
|||
_ {
|
||||
{ single-float-rep [ ^^alien-float ] }
|
||||
{ double-float-rep [ ^^alien-double ] }
|
||||
} case ^^box-float
|
||||
} case
|
||||
] inline-alien-getter ;
|
||||
|
||||
: emit-alien-float-setter ( node rep -- )
|
||||
|
|
|
|||
|
|
@ -1,19 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel compiler.cfg.stacks compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.utilities ;
|
||||
IN: compiler.cfg.intrinsics.float
|
||||
|
||||
: emit-float-op ( insn -- )
|
||||
[ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
|
||||
ds-push ; inline
|
||||
[ 2inputs ] dip call ds-push ; inline
|
||||
|
||||
: emit-float-comparison ( cc -- )
|
||||
[ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
|
||||
ds-push ; inline
|
||||
[ 2inputs ] dip ^^compare-float ds-push ; inline
|
||||
|
||||
: emit-float>fixnum ( -- )
|
||||
ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
|
||||
ds-pop ^^float>integer ^^tag-fixnum ds-push ;
|
||||
|
||||
: emit-fixnum>float ( -- )
|
||||
ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
|
||||
ds-pop ^^untag-fixnum ^^integer>float ds-push ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,20 @@
|
|||
IN: compiler.cfg.loop-detection.tests
|
||||
USING: compiler.cfg compiler.cfg.loop-detection
|
||||
compiler.cfg.predecessors
|
||||
compiler.cfg.debugger
|
||||
tools.test kernel namespaces accessors ;
|
||||
|
||||
V{ } 0 test-bb
|
||||
V{ } 1 test-bb
|
||||
V{ } 2 test-bb
|
||||
|
||||
0 { 1 2 } edges
|
||||
2 0 edge
|
||||
|
||||
: test-loop-detection ( -- ) cfg new 0 get >>entry compute-predecessors detect-loops drop ;
|
||||
|
||||
[ ] [ test-loop-detection ] unit-test
|
||||
|
||||
[ 1 ] [ 0 get loop-nesting-at ] unit-test
|
||||
[ 0 ] [ 1 get loop-nesting-at ] unit-test
|
||||
[ 1 ] [ 2 get loop-nesting-at ] unit-test
|
||||
|
|
@ -0,0 +1,80 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators deques dlists fry kernel
|
||||
namespaces sequences sets compiler.cfg ;
|
||||
IN: compiler.cfg.loop-detection
|
||||
|
||||
! Loop detection -- predecessors must be computed first
|
||||
|
||||
TUPLE: natural-loop header index ends blocks ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: loops
|
||||
|
||||
: <natural-loop> ( header index -- loop )
|
||||
H{ } clone H{ } clone natural-loop boa ;
|
||||
|
||||
: lookup-header ( header -- loop )
|
||||
loops get [
|
||||
loops get assoc-size <natural-loop>
|
||||
] cache ;
|
||||
|
||||
SYMBOLS: visited active ;
|
||||
|
||||
: record-back-edge ( from to -- )
|
||||
lookup-header ends>> conjoin ;
|
||||
|
||||
DEFER: find-loop-headers
|
||||
|
||||
: visit-edge ( from to -- )
|
||||
dup active get key?
|
||||
[ record-back-edge ]
|
||||
[ nip find-loop-headers ]
|
||||
if ;
|
||||
|
||||
: find-loop-headers ( bb -- )
|
||||
dup visited get key? [ drop ] [
|
||||
{
|
||||
[ visited get conjoin ]
|
||||
[ active get conjoin ]
|
||||
[ dup successors>> [ visit-edge ] with each ]
|
||||
[ active get delete-at ]
|
||||
} cleave
|
||||
] if ;
|
||||
|
||||
SYMBOL: work-list
|
||||
|
||||
: process-loop-block ( bb loop -- )
|
||||
2dup blocks>> key? [ 2drop ] [
|
||||
[ blocks>> conjoin ] [
|
||||
2dup header>> eq? [ 2drop ] [
|
||||
drop predecessors>> work-list get push-all-front
|
||||
] if
|
||||
] 2bi
|
||||
] if ;
|
||||
|
||||
: process-loop-ends ( loop -- )
|
||||
[ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
|
||||
'[ _ process-loop-block ] slurp-deque ;
|
||||
|
||||
: process-loop-headers ( -- )
|
||||
loops get values [ process-loop-ends ] each ;
|
||||
|
||||
SYMBOL: loop-nesting
|
||||
|
||||
: compute-loop-nesting ( -- )
|
||||
loops get H{ } clone [
|
||||
[ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
|
||||
] keep loop-nesting set ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
|
||||
|
||||
: detect-loops ( cfg -- cfg' )
|
||||
H{ } clone loops set
|
||||
H{ } clone visited set
|
||||
H{ } clone active set
|
||||
H{ } clone loop-nesting set
|
||||
dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
|
||||
|
|
@ -12,6 +12,8 @@ compiler.cfg.value-numbering
|
|||
compiler.cfg.copy-prop
|
||||
compiler.cfg.dce
|
||||
compiler.cfg.write-barrier
|
||||
compiler.cfg.representations
|
||||
compiler.cfg.loop-detection
|
||||
compiler.cfg.two-operand
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg.empty-blocks
|
||||
|
|
@ -44,6 +46,8 @@ SYMBOL: check-optimizer?
|
|||
copy-propagation
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
detect-loops
|
||||
select-representations
|
||||
convert-two-operand
|
||||
destruct-ssa
|
||||
delete-empty-blocks
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors namespaces kernel arrays parser math math.order ;
|
|||
IN: compiler.cfg.registers
|
||||
|
||||
! Virtual registers, used by CFG and machine IRs
|
||||
TUPLE: vreg { rep read-only } { n fixnum read-only } ;
|
||||
TUPLE: vreg rep { n fixnum read-only } ;
|
||||
|
||||
M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,82 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences arrays fry namespaces
|
||||
cpu.architecture compiler.cfg compiler.cfg.rpo
|
||||
compiler.cfg.instructions compiler.cfg.def-use ;
|
||||
IN: compiler.cfg.representations.preferred
|
||||
|
||||
GENERIC: defs-vreg-rep ( insn -- rep/f )
|
||||
GENERIC: temp-vreg-reps ( insn -- reps )
|
||||
GENERIC: uses-vreg-reps ( insn -- reps )
|
||||
|
||||
M: ##flushable defs-vreg-rep drop int-rep ;
|
||||
M: ##copy defs-vreg-rep rep>> ;
|
||||
M: output-float-insn defs-vreg-rep drop double-float-rep ;
|
||||
M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
|
||||
M: _fixnum-overflow defs-vreg-rep drop int-rep ;
|
||||
M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
|
||||
M: insn defs-vreg-rep drop f ;
|
||||
|
||||
M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##unary/temp temp-vreg-reps drop { int-rep } ;
|
||||
M: ##allot temp-vreg-reps drop { int-rep } ;
|
||||
M: ##dispatch temp-vreg-reps drop { int-rep } ;
|
||||
M: ##slot temp-vreg-reps drop { int-rep } ;
|
||||
M: ##set-slot temp-vreg-reps drop { int-rep } ;
|
||||
M: ##string-nth temp-vreg-reps drop { int-rep } ;
|
||||
M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-imm temp-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-float temp-vreg-reps drop { int-rep } ;
|
||||
M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
|
||||
M: _dispatch temp-vreg-reps drop { int-rep } ;
|
||||
M: insn temp-vreg-reps drop f ;
|
||||
|
||||
M: ##copy uses-vreg-reps rep>> 1array ;
|
||||
M: ##unary uses-vreg-reps drop { int-rep } ;
|
||||
M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
|
||||
M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##binary-imm uses-vreg-reps drop { int-rep } ;
|
||||
M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
|
||||
M: ##effect uses-vreg-reps drop { int-rep } ;
|
||||
M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##slot-imm uses-vreg-reps drop { int-rep } ;
|
||||
M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
|
||||
M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
|
||||
M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
|
||||
M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
|
||||
M: ##dispatch uses-vreg-reps drop { int-rep } ;
|
||||
M: ##alien-getter uses-vreg-reps drop { int-rep } ;
|
||||
M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
|
||||
M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
|
||||
M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
|
||||
M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
|
||||
M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
|
||||
M: _dispatch uses-vreg-reps drop { int-rep } ;
|
||||
M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
|
||||
M: insn uses-vreg-reps drop f ;
|
||||
|
||||
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
|
||||
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
|
||||
|
||||
: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
|
||||
[ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
|
||||
|
||||
: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
|
||||
[ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
|
||||
|
||||
: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
|
||||
'[
|
||||
[ basic-block set ] [
|
||||
instructions>> [
|
||||
dup ##phi? [ drop ] [
|
||||
_ [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri
|
||||
] if
|
||||
] each
|
||||
] bi
|
||||
] each-basic-block ; inline
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
USING: tools.test cpu.architecture
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.representations.preferred ;
|
||||
IN: compiler.cfg.representations
|
||||
|
||||
[ { double-float-rep double-float-rep } ] [
|
||||
T{ ##add-float
|
||||
{ dst V double-float-rep 5 }
|
||||
{ src1 V double-float-rep 3 }
|
||||
{ src2 V double-float-rep 4 }
|
||||
} uses-vreg-reps
|
||||
] unit-test
|
||||
|
||||
[ double-float-rep ] [
|
||||
T{ ##alien-double
|
||||
{ dst V double-float-rep 5 }
|
||||
{ src V int-rep 3 }
|
||||
} defs-vreg-rep
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,157 @@
|
|||
! Copyright (C) 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel fry accessors sequences assocs sets namespaces
|
||||
arrays combinators make locals cpu.architecture compiler.utilities
|
||||
compiler.cfg
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.def-use
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.loop-detection
|
||||
compiler.cfg.renaming.functor
|
||||
compiler.cfg.representations.preferred ;
|
||||
IN: compiler.cfg.representations
|
||||
|
||||
! Virtual register representation selection.
|
||||
! Still needs a loop nesting heuristic
|
||||
|
||||
! For every vreg, compute possible representations.
|
||||
SYMBOL: possibilities
|
||||
|
||||
: possible ( vreg -- reps ) possibilities get at ;
|
||||
|
||||
: compute-possibilities ( cfg -- )
|
||||
H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
|
||||
[ keys ] assoc-map possibilities set ;
|
||||
|
||||
! For every vreg, compute the cost of keeping it in every possible
|
||||
! representation.
|
||||
|
||||
! Cost map maps vreg to representation to cost.
|
||||
SYMBOL: costs
|
||||
|
||||
: init-costs ( -- )
|
||||
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
|
||||
|
||||
: increase-cost ( rep vreg -- )
|
||||
! Increase cost of keeping vreg in rep, making a choice of rep less
|
||||
! likely.
|
||||
[ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
|
||||
|
||||
: maybe-increase-cost ( possible vreg preferred -- )
|
||||
pick eq? [ 2drop ] [ increase-cost ] if ;
|
||||
|
||||
: representation-cost ( vreg preferred -- )
|
||||
! 'preferred' is a representation that the instruction can accept with no cost.
|
||||
! So, for each representation that's not preferred, increase the cost of keeping
|
||||
! the vreg in that representation.
|
||||
[ drop possible ]
|
||||
[ '[ _ _ maybe-increase-cost ] ]
|
||||
2bi each ;
|
||||
|
||||
! For every vreg, compute preferred representation, that minimizes costs.
|
||||
SYMBOL: preferred
|
||||
|
||||
: minimize-costs ( -- )
|
||||
costs get [ >alist alist-min first ] assoc-map preferred set ;
|
||||
|
||||
: compute-costs ( cfg -- )
|
||||
init-costs
|
||||
[ representation-cost ] with-vreg-reps
|
||||
minimize-costs ;
|
||||
|
||||
! Insert conversions. This introduces new temporaries, so we need
|
||||
! to rename opearands too.
|
||||
|
||||
: emit-conversion ( dst src dst-rep src-rep -- )
|
||||
2array {
|
||||
{ { int-rep int-rep } [ int-rep ##copy ] }
|
||||
{ { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
|
||||
{ { double-float-rep int-rep } [ ##unbox-float ] }
|
||||
{ { int-rep double-float-rep } [ i ##box-float ] }
|
||||
} case ;
|
||||
|
||||
:: emit-def-conversion ( dst preferred required -- new-dst' )
|
||||
! If an instruction defines a register with representation 'required',
|
||||
! but the register has preferred representation 'preferred', then
|
||||
! we rename the instruction's definition to a new register, which
|
||||
! becomes the input of a conversion instruction.
|
||||
dst required next-vreg [ preferred required emit-conversion ] keep ;
|
||||
|
||||
:: emit-use-conversion ( src preferred required -- new-src' )
|
||||
! If an instruction uses a register with representation 'required',
|
||||
! but the register has preferred representation 'preferred', then
|
||||
! we rename the instruction's input to a new register, which
|
||||
! becomes the output of a conversion instruction.
|
||||
required next-vreg [ src required preferred emit-conversion ] keep ;
|
||||
|
||||
SYMBOLS: renaming-set needs-renaming? ;
|
||||
|
||||
: init-renaming-set ( -- )
|
||||
needs-renaming? off
|
||||
V{ } clone renaming-set set ;
|
||||
|
||||
: no-renaming ( vreg -- )
|
||||
dup 2array renaming-set get push ;
|
||||
|
||||
: record-renaming ( from to -- )
|
||||
2array renaming-set get push needs-renaming? on ;
|
||||
|
||||
:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- ) -- )
|
||||
vreg preferred get at :> preferred
|
||||
preferred required eq?
|
||||
[ vreg no-renaming ]
|
||||
[ vreg vreg preferred required quot call record-renaming ] if ; inline
|
||||
|
||||
: compute-renaming-set ( insn -- )
|
||||
! temp vregs don't need conversions since they're always in their
|
||||
! preferred representation
|
||||
init-renaming-set
|
||||
[ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
|
||||
[ , ]
|
||||
[ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
|
||||
tri ;
|
||||
|
||||
: converted-value ( vreg -- vreg' )
|
||||
renaming-set get pop first2 [ assert= ] dip ;
|
||||
|
||||
RENAMING: convert [ converted-value ] [ converted-value ] [ ]
|
||||
|
||||
: perform-renaming ( insn -- )
|
||||
needs-renaming? get [
|
||||
renaming-set get reverse-here
|
||||
[ convert-insn-uses ] [ convert-insn-defs ] bi
|
||||
renaming-set get length 0 assert=
|
||||
] [ drop ] if ;
|
||||
|
||||
GENERIC: conversions-for-insn ( insn -- )
|
||||
|
||||
! Inserting conversions for a phi is done in compiler.cfg.cssa
|
||||
M: ##phi conversions-for-insn , ;
|
||||
|
||||
M: vreg-insn conversions-for-insn
|
||||
[ compute-renaming-set ] [ perform-renaming ] bi ;
|
||||
|
||||
M: insn conversions-for-insn , ;
|
||||
|
||||
: conversions-for-block ( bb -- )
|
||||
dup kill-block? [ drop ] [
|
||||
[
|
||||
[
|
||||
[ conversions-for-insn ] each
|
||||
] V{ } make
|
||||
] change-instructions drop
|
||||
] if ;
|
||||
|
||||
: insert-conversions ( cfg -- )
|
||||
[ conversions-for-block ] each-basic-block ;
|
||||
|
||||
: select-representations ( cfg -- cfg' )
|
||||
{
|
||||
[ compute-possibilities ]
|
||||
[ compute-costs ]
|
||||
[ insert-conversions ]
|
||||
[ preferred get [ >>rep drop ] assoc-each ]
|
||||
} cleave ;
|
||||
|
|
@ -1,22 +1,23 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel locals
|
||||
USING: accessors assocs kernel locals fry
|
||||
cpu.architecture
|
||||
compiler.cfg.rpo
|
||||
compiler.cfg.hats
|
||||
compiler.cfg.utilities
|
||||
compiler.cfg.instructions ;
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.representations ;
|
||||
IN: compiler.cfg.ssa.cssa
|
||||
|
||||
! Convert SSA to conventional SSA.
|
||||
|
||||
:: insert-copy ( bb src -- bb dst )
|
||||
i :> dst
|
||||
bb [ dst src int-rep ##copy ] add-instructions
|
||||
:: insert-copy ( bb src rep -- bb dst )
|
||||
rep next-vreg :> dst
|
||||
bb [ dst src rep src rep>> emit-conversion ] add-instructions
|
||||
bb dst ;
|
||||
|
||||
: convert-phi ( ##phi -- )
|
||||
[ [ insert-copy ] assoc-map ] change-inputs drop ;
|
||||
dup dst>> rep>> '[ [ _ insert-copy ] assoc-map ] change-inputs drop ;
|
||||
|
||||
: construct-cssa ( cfg -- )
|
||||
[ [ convert-phi ] each-phi ] each-basic-block ;
|
||||
|
|
@ -49,7 +49,10 @@ SYMBOL: copies
|
|||
: eliminate-copy ( vreg1 vreg2 -- )
|
||||
[ leader ] bi@
|
||||
2dup eq? [ 2drop ] [
|
||||
[ update-leaders ] [ merge-classes ] 2bi
|
||||
[ [ rep>> ] bi@ assert= ]
|
||||
[ update-leaders ]
|
||||
[ merge-classes ]
|
||||
2tri
|
||||
] if ;
|
||||
|
||||
: introduce-vreg ( vreg -- )
|
||||
|
|
|
|||
|
|
@ -9,21 +9,14 @@ IN: compiler.cfg.value-numbering.simplify
|
|||
! Return value of f means we didn't simplify.
|
||||
GENERIC: simplify* ( expr -- vn/expr/f )
|
||||
|
||||
: simplify-unbox ( in boxer -- vn/expr/f )
|
||||
over op>> eq? [ in>> ] [ drop f ] if ; inline
|
||||
|
||||
: simplify-unbox-float ( in -- vn/expr/f )
|
||||
\ ##box-float simplify-unbox ; inline
|
||||
|
||||
: simplify-unbox-alien ( in -- vn/expr/f )
|
||||
\ ##box-alien simplify-unbox ; inline
|
||||
dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
|
||||
|
||||
M: unary-expr simplify*
|
||||
#! Note the copy propagation: a copy always simplifies to
|
||||
#! its source VN.
|
||||
[ in>> vn>expr ] [ op>> ] bi {
|
||||
{ \ ##copy [ ] }
|
||||
{ \ ##unbox-float [ simplify-unbox-float ] }
|
||||
{ \ ##unbox-alien [ simplify-unbox-alien ] }
|
||||
{ \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
|
||||
[ 2drop f ]
|
||||
|
|
|
|||
|
|
@ -26,8 +26,12 @@ SYMBOL: yield-hook
|
|||
|
||||
yield-hook [ [ ] ] initialize
|
||||
|
||||
: alist-max ( alist -- pair )
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
|
||||
: alist-most ( alist quot -- pair )
|
||||
[ [ ] ] dip '[ [ [ second ] bi@ @ ] most ] map-reduce ; inline
|
||||
|
||||
: alist-min ( alist -- pair ) [ before? ] alist-most ;
|
||||
|
||||
: alist-max ( alist -- pair ) [ after? ] alist-most ;
|
||||
|
||||
: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue