} 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 ;
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 ;
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 ;
: 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 -- )
{
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:
: linear-scan ( cfg -- cfg' )
[
+ init-mapping
dup reverse-post-order machine-registers (linear-scan)
spill-counts get >>spill-counts
] with-scope ;
--- /dev/null
+! 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 ;
\ No newline at end of file
-! 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?
[ 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 >= ]
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( rpo -- )
- H{ } clone spill-temps set
[ resolve-block-data-flow ] each ;
[ 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
\ No newline at end of file
projects / factor.git / commitdiff