diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index 9949832294..c747d2b404 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index c995569c2e..143e84aaf4 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -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>> ] [ 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 -- ) { diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 9013389cc9..77d66c274d 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -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 ; diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor new file mode 100644 index 0000000000..5b47f33c64 --- /dev/null +++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor @@ -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 ] + [ reg-class>> ] + tri \ register->memory boa + ] [ + [ reg-class>> spill-temp ] + [ 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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 196d8e439f..7b7f242e4e 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -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 ] - [ reg-class>> ] - tri \ register->memory boa - ] [ - [ reg-class>> spill-temp ] - [ 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 ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 0e6deb7746..004b543c7f 100644 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -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 \ No newline at end of file