compiler.cfg.linear-scan: split off parallel mapping code from resolve pass, use it in assignment pass to resolve parallel copies
Slava Pestov
parent
463a63d470
commit
c20e6c290f
|
|
@ -38,7 +38,7 @@ ERROR: bad-live-ranges interval ;
|
|||
} 2cleave ;
|
||||
|
||||
: assign-spill ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>spill-to drop ;
|
||||
dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
|
||||
|
||||
: assign-reload ( live-interval -- )
|
||||
dup vreg>> assign-spill-slot >>reload-from drop ;
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ compiler.cfg.def-use
|
|||
compiler.cfg.liveness
|
||||
compiler.cfg.registers
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.mapping
|
||||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.live-intervals ;
|
||||
|
|
@ -42,16 +43,11 @@ SYMBOL: register-live-outs
|
|||
H{ } clone register-live-outs set
|
||||
init-unhandled ;
|
||||
|
||||
: insert-spill ( live-interval -- )
|
||||
{
|
||||
[ reg>> ]
|
||||
[ vreg>> reg-class>> ]
|
||||
[ spill-to>> ]
|
||||
[ end>> ]
|
||||
} cleave f swap \ _spill boa , ;
|
||||
|
||||
: handle-spill ( live-interval -- )
|
||||
dup spill-to>> [ insert-spill ] [ drop ] if ;
|
||||
dup spill-to>> [
|
||||
[ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
|
||||
register->memory
|
||||
] [ drop ] if ;
|
||||
|
||||
: first-split ( live-interval -- live-interval' )
|
||||
dup split-before>> [ first-split ] [ ] ?if ;
|
||||
|
|
@ -59,22 +55,19 @@ SYMBOL: register-live-outs
|
|||
: next-interval ( live-interval -- live-interval' )
|
||||
split-next>> first-split ;
|
||||
|
||||
: insert-copy ( live-interval -- )
|
||||
{
|
||||
[ next-interval reg>> ]
|
||||
[ reg>> ]
|
||||
[ vreg>> reg-class>> ]
|
||||
[ end>> ]
|
||||
} cleave f swap \ _copy boa , ;
|
||||
|
||||
: handle-copy ( live-interval -- )
|
||||
dup split-next>> [ insert-copy ] [ drop ] if ;
|
||||
dup split-next>> [
|
||||
[ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
|
||||
register->register
|
||||
] [ drop ] if ;
|
||||
|
||||
: expire-old-intervals ( n -- )
|
||||
[ pending-intervals get ] dip '[
|
||||
dup end>> _ <
|
||||
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
|
||||
] filter-here ;
|
||||
[
|
||||
[ pending-intervals get ] dip '[
|
||||
dup end>> _ <
|
||||
[ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
|
||||
] filter-here
|
||||
] { } make mapping-instructions % ;
|
||||
|
||||
: insert-reload ( live-interval -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ compiler.cfg.linear-scan.live-intervals
|
|||
compiler.cfg.linear-scan.allocation
|
||||
compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.linear-scan.resolve ;
|
||||
compiler.cfg.linear-scan.resolve
|
||||
compiler.cfg.linear-scan.mapping ;
|
||||
IN: compiler.cfg.linear-scan
|
||||
|
||||
! References:
|
||||
|
|
@ -36,6 +37,7 @@ IN: compiler.cfg.linear-scan
|
|||
|
||||
: linear-scan ( cfg -- cfg' )
|
||||
[
|
||||
init-mapping
|
||||
dup reverse-post-order machine-registers (linear-scan)
|
||||
spill-counts get >>spill-counts
|
||||
] with-scope ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,148 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.allocation.state fry hashtables kernel
|
||||
locals make namespaces parser sequences sets words ;
|
||||
IN: compiler.cfg.linear-scan.mapping
|
||||
|
||||
SYMBOL: spill-temps
|
||||
|
||||
: spill-temp ( reg-class -- n )
|
||||
spill-temps get [ next-spill-slot ] cache ;
|
||||
|
||||
<<
|
||||
|
||||
TUPLE: operation from to reg-class ;
|
||||
|
||||
SYNTAX: OPERATION:
|
||||
CREATE-CLASS dup save-location
|
||||
[ operation { } define-tuple-class ]
|
||||
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
|
||||
|
||||
>>
|
||||
|
||||
OPERATION: register->memory
|
||||
OPERATION: memory->register
|
||||
OPERATION: register->register
|
||||
|
||||
! This should never come up because of how spill slots are assigned,
|
||||
! so make it an error.
|
||||
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
|
||||
|
||||
GENERIC: >insn ( operation -- )
|
||||
|
||||
M: register->memory >insn
|
||||
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
|
||||
|
||||
M: memory->register >insn
|
||||
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
|
||||
|
||||
M: register->register >insn
|
||||
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
|
||||
|
||||
SYMBOL: froms
|
||||
SYMBOL: tos
|
||||
|
||||
SINGLETONS: memory register ;
|
||||
|
||||
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
|
||||
|
||||
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
|
||||
|
||||
: from-reg ( operation -- seq )
|
||||
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
|
||||
|
||||
: to-reg ( operation -- seq )
|
||||
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
|
||||
|
||||
: start? ( operations -- pair )
|
||||
from-reg tos get key? not ;
|
||||
|
||||
: independent-assignment? ( operations -- pair )
|
||||
to-reg froms get key? not ;
|
||||
|
||||
: set-tos/froms ( operations -- )
|
||||
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
|
||||
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
|
||||
bi ;
|
||||
|
||||
:: (trace-chain) ( obj hashtable -- )
|
||||
obj to-reg froms get at* [
|
||||
dup ,
|
||||
obj over hashtable clone [ maybe-set-at ] keep swap
|
||||
[ (trace-chain) ] [ 2drop ] if
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: trace-chain ( obj -- seq )
|
||||
[
|
||||
dup ,
|
||||
dup dup associate (trace-chain)
|
||||
] { } make prune reverse ;
|
||||
|
||||
: trace-chains ( seq -- seq' )
|
||||
[ trace-chain ] map concat ;
|
||||
|
||||
ERROR: resolve-error ;
|
||||
|
||||
: split-cycle ( operations -- chain spilled-operation )
|
||||
unclip [
|
||||
[ set-tos/froms ]
|
||||
[
|
||||
[ start? ] find nip
|
||||
[ resolve-error ] unless* trace-chain
|
||||
] bi
|
||||
] dip ;
|
||||
|
||||
: break-cycle-n ( operations -- operations' )
|
||||
split-cycle [
|
||||
[ from>> ]
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ reg-class>> ]
|
||||
tri \ register->memory boa
|
||||
] [
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ to>> ]
|
||||
[ reg-class>> ]
|
||||
tri \ memory->register boa
|
||||
] bi [ 1array ] bi@ surround ;
|
||||
|
||||
: break-cycle ( operations -- operations' )
|
||||
dup length {
|
||||
{ 1 [ ] }
|
||||
[ drop break-cycle-n ]
|
||||
} case ;
|
||||
|
||||
: (group-cycles) ( seq -- )
|
||||
[
|
||||
dup set-tos/froms
|
||||
unclip trace-chain
|
||||
[ diff ] keep , (group-cycles)
|
||||
] unless-empty ;
|
||||
|
||||
: group-cycles ( seq -- seqs )
|
||||
[ (group-cycles) ] { } make ;
|
||||
|
||||
: remove-dead-mappings ( seq -- seq' )
|
||||
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
|
||||
|
||||
: parallel-mappings ( operations -- seq )
|
||||
[
|
||||
[ independent-assignment? not ] partition %
|
||||
[ start? not ] partition
|
||||
[ trace-chain ] map concat dup %
|
||||
diff group-cycles [ break-cycle ] map concat %
|
||||
] { } make remove-dead-mappings ;
|
||||
|
||||
: mapping-instructions ( mappings -- insns )
|
||||
[ { } ] [
|
||||
[
|
||||
[ set-tos/froms ] [ parallel-mappings ] bi
|
||||
[ [ >insn ] each ] { } make
|
||||
] with-scope
|
||||
] if-empty ;
|
||||
|
||||
: init-mapping ( -- )
|
||||
H{ } clone spill-temps set ;
|
||||
|
|
@ -1,36 +1,13 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes.parser classes.tuple
|
||||
combinators combinators.short-circuit fry hashtables kernel locals
|
||||
make math math.order namespaces sequences sets words parser
|
||||
compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
|
||||
compiler.cfg.linear-scan.assignment compiler.cfg.liveness ;
|
||||
USING: accessors arrays assocs combinators
|
||||
combinators.short-circuit fry kernel locals
|
||||
make math sequences
|
||||
compiler.cfg.instructions
|
||||
compiler.cfg.linear-scan.assignment
|
||||
compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
|
||||
IN: compiler.cfg.linear-scan.resolve
|
||||
|
||||
SYMBOL: spill-temps
|
||||
|
||||
: spill-temp ( reg-class -- n )
|
||||
spill-temps get [ next-spill-slot ] cache ;
|
||||
|
||||
<<
|
||||
|
||||
TUPLE: operation from to reg-class ;
|
||||
|
||||
SYNTAX: OPERATION:
|
||||
CREATE-CLASS dup save-location
|
||||
[ operation { } define-tuple-class ]
|
||||
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
|
||||
|
||||
>>
|
||||
|
||||
OPERATION: register->memory
|
||||
OPERATION: memory->register
|
||||
OPERATION: register->register
|
||||
|
||||
! This should never come up because of how spill slots are assigned,
|
||||
! so make it an error.
|
||||
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
|
||||
|
||||
: add-mapping ( from to reg-class -- )
|
||||
over spill-slot? [
|
||||
pick spill-slot?
|
||||
|
|
@ -53,118 +30,6 @@ OPERATION: register->register
|
|||
[ resolve-value-data-flow ] with with each
|
||||
] { } make ;
|
||||
|
||||
GENERIC: >insn ( operation -- )
|
||||
|
||||
M: register->memory >insn
|
||||
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
|
||||
|
||||
M: memory->register >insn
|
||||
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
|
||||
|
||||
M: register->register >insn
|
||||
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
|
||||
|
||||
SYMBOL: froms
|
||||
SYMBOL: tos
|
||||
|
||||
SINGLETONS: memory register ;
|
||||
|
||||
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
|
||||
|
||||
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
|
||||
|
||||
: from-reg ( operation -- seq )
|
||||
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
|
||||
|
||||
: to-reg ( operation -- seq )
|
||||
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
|
||||
|
||||
: start? ( operations -- pair )
|
||||
from-reg tos get key? not ;
|
||||
|
||||
: independent-assignment? ( operations -- pair )
|
||||
to-reg froms get key? not ;
|
||||
|
||||
: set-tos/froms ( operations -- )
|
||||
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
|
||||
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
|
||||
bi ;
|
||||
|
||||
:: (trace-chain) ( obj hashtable -- )
|
||||
obj to-reg froms get at* [
|
||||
dup ,
|
||||
obj over hashtable clone [ maybe-set-at ] keep swap
|
||||
[ (trace-chain) ] [ 2drop ] if
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: trace-chain ( obj -- seq )
|
||||
[
|
||||
dup ,
|
||||
dup dup associate (trace-chain)
|
||||
] { } make prune reverse ;
|
||||
|
||||
: trace-chains ( seq -- seq' )
|
||||
[ trace-chain ] map concat ;
|
||||
|
||||
ERROR: resolve-error ;
|
||||
|
||||
: split-cycle ( operations -- chain spilled-operation )
|
||||
unclip [
|
||||
[ set-tos/froms ]
|
||||
[
|
||||
[ start? ] find nip
|
||||
[ resolve-error ] unless* trace-chain
|
||||
] bi
|
||||
] dip ;
|
||||
|
||||
: break-cycle-n ( operations -- operations' )
|
||||
split-cycle [
|
||||
[ from>> ]
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ reg-class>> ]
|
||||
tri \ register->memory boa
|
||||
] [
|
||||
[ reg-class>> spill-temp <spill-slot> ]
|
||||
[ to>> ]
|
||||
[ reg-class>> ]
|
||||
tri \ memory->register boa
|
||||
] bi [ 1array ] bi@ surround ;
|
||||
|
||||
: break-cycle ( operations -- operations' )
|
||||
dup length {
|
||||
{ 1 [ ] }
|
||||
[ drop break-cycle-n ]
|
||||
} case ;
|
||||
|
||||
: (group-cycles) ( seq -- )
|
||||
[
|
||||
dup set-tos/froms
|
||||
unclip trace-chain
|
||||
[ diff ] keep , (group-cycles)
|
||||
] unless-empty ;
|
||||
|
||||
: group-cycles ( seq -- seqs )
|
||||
[ (group-cycles) ] { } make ;
|
||||
|
||||
: remove-dead-mappings ( seq -- seq' )
|
||||
prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
|
||||
|
||||
: parallel-mappings ( operations -- seq )
|
||||
[
|
||||
[ independent-assignment? not ] partition %
|
||||
[ start? not ] partition
|
||||
[ trace-chain ] map concat dup %
|
||||
diff group-cycles [ break-cycle ] map concat %
|
||||
] { } make remove-dead-mappings ;
|
||||
|
||||
: mapping-instructions ( mappings -- insns )
|
||||
[
|
||||
[ set-tos/froms ] [ parallel-mappings ] bi
|
||||
[ [ >insn ] each ] { } make
|
||||
] with-scope ;
|
||||
|
||||
: fork? ( from to -- ? )
|
||||
{
|
||||
[ drop successors>> length 1 >= ]
|
||||
|
|
@ -206,5 +71,4 @@ ERROR: resolve-error ;
|
|||
dup successors>> [ resolve-edge-data-flow ] with each ;
|
||||
|
||||
: resolve-data-flow ( rpo -- )
|
||||
H{ } clone spill-temps set
|
||||
[ resolve-block-data-flow ] each ;
|
||||
|
|
|
|||
|
|
@ -176,3 +176,6 @@ H{ } "x" set
|
|||
[ 1 ] [ "h" get assoc-size ] unit-test
|
||||
|
||||
[ 1 ] [ 2 "h" get at ] unit-test
|
||||
|
||||
! Random test case
|
||||
[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
|
||||
Loading…
Reference in New Issue