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 ;
-: handle-spill ( live-interval -- )
- 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 ;
+: insert-spill ( live-interval -- )
+ [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
-: next-interval ( live-interval -- live-interval' )
- split-next>> first-split ;
-
-: handle-copy ( live-interval -- )
- dup split-next>> [
- [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
- register->register
- ] [ drop ] if ;
+: handle-spill ( live-interval -- )
+ dup spill-to>> [ insert-spill ] [ drop ] if ;
: (expire-old-intervals) ( n heap -- )
dup heap-empty? [ 2drop ] [
2dup heap-peek nip <= [ 2drop ] [
- dup heap-pop drop [ handle-spill ] [ handle-copy ] bi
+ dup heap-pop drop handle-spill
(expire-old-intervals)
] if
] if ;
: expire-old-intervals ( n -- )
- [
- pending-intervals get (expire-old-intervals)
- ] { } make mapping-instructions % ;
+ pending-intervals get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- {
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ reload-from>> ]
- [ start>> ]
- } cleave f swap \ _reload boa , ;
+ [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
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.mapping ;
+compiler.cfg.linear-scan.resolve ;
IN: compiler.cfg.linear-scan
! References:
: linear-scan ( cfg -- cfg' )
[
- init-mapping
dup machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed
+++ /dev/null
-USING: compiler.cfg.instructions
-compiler.cfg.linear-scan.allocation.state
-compiler.cfg.linear-scan.mapping cpu.architecture kernel
-namespaces tools.test ;
-IN: compiler.cfg.linear-scan.mapping.tests
-
-H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
-init-mapping
-
-[
- {
- T{ _copy { dst 5 } { src 4 } { class int-regs } }
- T{ _spill { src 1 } { class int-regs } { n 10 } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 10 } }
- T{ _spill { src 1 } { class float-regs } { n 20 } }
- T{ _copy { dst 1 } { src 0 } { class float-regs } }
- T{ _reload { dst 0 } { class float-regs } { n 20 } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
- T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
- T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _spill { src 2 } { class int-regs } { n 10 } }
- T{ _copy { dst 2 } { src 1 } { class int-regs } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _reload { dst 0 } { class int-regs } { n 10 } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _spill { src 0 } { class int-regs } { n 10 } }
- T{ _copy { dst 0 } { src 2 } { class int-regs } }
- T{ _copy { dst 2 } { src 1 } { class int-regs } }
- T{ _reload { dst 1 } { class int-regs } { n 10 } }
- }
-] [
- {
- T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _copy { dst 2 } { src 0 } { class int-regs } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- { }
-] [
- {
- T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _spill { src 3 } { class int-regs } { n 4 } }
- T{ _reload { dst 2 } { class int-regs } { n 1 } }
- }
-] [
- {
- T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
- T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-
-[
- {
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _copy { dst 2 } { src 0 } { class int-regs } }
- T{ _copy { dst 0 } { src 3 } { class int-regs } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _copy { dst 2 } { src 0 } { class int-regs } }
- T{ _spill { src 4 } { class int-regs } { n 10 } }
- T{ _copy { dst 4 } { src 0 } { class int-regs } }
- T{ _copy { dst 0 } { src 3 } { class int-regs } }
- T{ _reload { dst 3 } { class int-regs } { n 10 } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
-
-[
- {
- T{ _copy { dst 2 } { src 0 } { class int-regs } }
- T{ _copy { dst 9 } { src 1 } { class int-regs } }
- T{ _copy { dst 1 } { src 0 } { class int-regs } }
- T{ _spill { src 4 } { class int-regs } { n 10 } }
- T{ _copy { dst 4 } { src 0 } { class int-regs } }
- T{ _copy { dst 0 } { src 3 } { class int-regs } }
- T{ _reload { dst 3 } { class int-regs } { n 10 } }
- }
-] [
- {
- T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
- T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
- T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
- T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
- T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
- } mapping-instructions
-] unit-test
+++ /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
-
-: from-reg ( operation -- seq )
- [ from>> ] [ reg-class>> ] bi 2array ;
-
-: to-reg ( operation -- seq )
- [ to>> ] [ reg-class>> ] bi 2array ;
-
-: 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.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
-combinators.short-circuit fry kernel locals
-make math sequences
+combinators.short-circuit fry kernel locals namespaces
+make math sequences hashtables
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.utilities
compiler.cfg.instructions
+compiler.cfg.parallel-copy
compiler.cfg.linear-scan.assignment
-compiler.cfg.linear-scan.mapping ;
+compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve
+SYMBOL: spill-temps
+
+: spill-temp ( reg-class -- n )
+ spill-temps get [ next-spill-slot ] cache ;
+
: add-mapping ( from to reg-class -- )
- over spill-slot? [
- pick spill-slot?
- [ memory->memory ]
- [ register->memory ] if
- ] [
- pick spill-slot?
- [ memory->register ]
- [ register->register ] if
- ] if ;
+ '[ _ 2array ] bi@ 2array , ;
:: resolve-value-data-flow ( bb to vreg -- )
vreg bb vreg-at-end
[ resolve-value-data-flow ] with with each
] { } make ;
+: memory->register ( from to -- )
+ swap [ first2 ] [ first n>> ] bi* _reload ;
+
+: register->memory ( from to -- )
+ [ first2 ] [ first n>> ] bi* _spill ;
+
+: temp->register ( from to -- )
+ nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
+
+: register->temp ( from to -- )
+ drop [ first2 ] [ second spill-temp ] bi _spill ;
+
+: register->register ( from to -- )
+ swap [ first ] [ first2 ] bi* _copy ;
+
+SYMBOL: temp
+
+: >insn ( from to -- )
+ {
+ { [ over temp eq? ] [ temp->register ] }
+ { [ dup temp eq? ] [ register->temp ] }
+ { [ over first spill-slot? ] [ memory->register ] }
+ { [ dup first spill-slot? ] [ register->memory ] }
+ [ register->register ]
+ } cond ;
+
+: mapping-instructions ( alist -- insns )
+ >hashtable
+ [ temp [ swap >insn ] parallel-mapping ] { } make ;
+
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
mapping-instructions <simple-block>
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
+ H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;
temp set
<dlist> to-do set
<dlist> ready set
- [ preds set ]
+ [ [ eq? not ] assoc-filter preds set ]
[ [ nip dup ] H{ } assoc-map-as locs set ]
[ keys [ init-to-do ] [ init-ready ] bi ] tri ;
projects / factor.git / commitdiff