diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 56f0452d1a..a2b12300f7 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -240,7 +240,7 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; INSN: _compare-float-branch < _conditional-branch ; -TUPLE: spill-slot { n integer } ; C: spill-slot +TUPLE: spill-slot n ; C: spill-slot INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0ade81311a..c95771835a 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -33,6 +33,20 @@ SYMBOL: spill-slots : spill-slots-for ( vreg -- assoc ) reg-class>> spill-slots get at ; +! Mapping from basic blocks to values which are live at the start +SYMBOL: register-live-ins + +! Mapping from basic blocks to values which are live at the end +SYMBOL: register-live-outs + +: init-assignment ( live-intervals -- ) + V{ } clone pending-intervals set + unhandled-intervals set + [ H{ } clone ] reg-class-assoc spill-slots set + H{ } clone register-live-ins set + H{ } clone register-live-outs set + init-unhandled ; + ERROR: already-spilled ; : record-spill ( live-interval -- ) @@ -102,6 +116,9 @@ ERROR: already-reloaded ; ] [ 2drop ] if ] if ; +: prepare-insn ( insn -- ) + insn#>> [ expire-old-intervals ] [ activate-new-intervals ] bi ; + GENERIC: assign-registers-in-insn ( insn -- ) : register-mapping ( live-intervals -- alist ) @@ -118,60 +135,65 @@ ERROR: overlapping-registers intervals ; dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ; -: active-intervals ( insn -- intervals ) - insn#>> pending-intervals get [ covers? ] with filter +: active-intervals ( n -- intervals ) + pending-intervals get [ covers? ] with filter check-assignment? get [ dup check-assignment ] when ; M: vreg-insn assign-registers-in-insn - dup [ active-intervals ] [ all-vregs ] bi + dup [ insn#>> active-intervals ] [ all-vregs ] bi '[ vreg>> _ member? ] filter register-mapping >>regs drop ; -: compute-live-registers ( insn -- assoc ) - [ active-intervals ] [ temp-vregs ] bi - '[ vreg>> _ memq? not ] filter - register-mapping ; +: compute-live-registers ( n -- assoc ) + active-intervals register-mapping ; : compute-live-spill-slots ( -- assocs ) - spill-slots get values - [ [ vreg>> swap ] H{ } assoc-map-as ] map ; + spill-slots get values first2 + [ [ vreg>> swap ] H{ } assoc-map-as ] bi@ + assoc-union ; -: compute-live-values ( insn -- assoc ) - [ compute-live-spill-slots ] dip compute-live-registers suffix - assoc-combine ; +: compute-live-values ( n -- assoc ) + [ compute-live-spill-slots ] dip compute-live-registers + assoc-union ; + +: compute-live-gc-values ( insn -- assoc ) + [ insn#>> compute-live-values ] [ temp-vregs ] bi + '[ drop _ memq? not ] assoc-filter ; M: ##gc assign-registers-in-insn dup call-next-method - dup compute-live-values >>live-values + dup compute-live-gc-values >>live-values drop ; M: insn assign-registers-in-insn drop ; -: init-assignment ( live-intervals -- ) - V{ } clone pending-intervals set - unhandled-intervals set - [ H{ } clone ] reg-class-assoc spill-slots set - init-unhandled ; +: begin-block ( bb -- ) + [ block-from compute-live-values ] keep register-live-ins get set-at ; + +: end-block ( bb -- ) + [ block-to compute-live-values ] keep register-live-outs get set-at ; + +: vreg-at-start ( vreg bb -- state ) register-live-ins get at at ; + +: vreg-at-end ( vreg bb -- state ) register-live-outs get at at ; : assign-registers-in-block ( bb -- ) + dup + begin-block [ [ [ - [ - insn#>> - [ expire-old-intervals ] - [ activate-new-intervals ] - bi - ] + [ prepare-insn ] [ assign-registers-in-insn ] [ , ] tri ] each ] V{ } make - ] change-instructions drop ; + ] change-instructions + end-block ; : assign-registers ( live-intervals rpo -- ) [ init-assignment ] dip diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 65778a3e7b..377b3bff74 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -1353,7 +1353,7 @@ USING: math.private ; ! Spill slot liveness was computed incorrectly, leading to a FEP ! early in bootstrap on x86-32 -[ t t ] [ +[ t ] [ [ H{ } clone live-ins set H{ } clone live-outs set @@ -1379,8 +1379,7 @@ USING: math.private ; } } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) instructions>> first - [ live-spill-slots>> empty? ] - [ live-registers>> empty? ] bi + live-values>> assoc-empty? ] with-scope ] unit-test @@ -1859,4 +1858,56 @@ test-diamond [ _spill ] [ 3 get instructions>> second class ] unit-test -[ _reload ] [ 4 get instructions>> first class ] unit-test \ No newline at end of file +[ _reload ] [ 4 get instructions>> first class ] unit-test + +! Resolve pass +V{ + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-imm-branch f V int-regs 0 5 cc= } +} 1 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 0 } + T{ ##peek f V int-regs 2 D 0 } + T{ ##replace f V int-regs 1 D 0 } + T{ ##replace f V int-regs 2 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek f V int-regs 1 D 0 } + T{ ##compare-imm-branch f V int-regs 1 5 cc= } +} 4 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 5 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 6 test-bb + +0 get 1 get V{ } 1sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get V{ } 1sequence >>successors drop +3 get 4 get V{ } 1sequence >>successors drop +4 get 5 get 6 get V{ } 2sequence >>successors drop + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test + +[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test + +[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index f2d71691aa..4c27e5c4eb 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -12,59 +12,6 @@ IN: compiler.cfg.linear-scan.resolve.tests { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array ] unit-test -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##replace f V int-regs 0 D 1 } - T{ ##return } -} 1 test-bb - -1 get 1vector 0 get (>>successors) - -cfg new 0 get >>entry -compute-predecessors -dup reverse-post-order number-instructions -drop - -CONSTANT: test-live-interval-1 -T{ live-interval - { start 0 } - { end 6 } - { uses V{ 0 6 } } - { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } } - { spill-to 0 } - { vreg V int-regs 0 } -} - -[ f ] [ - test-live-interval-1 0 get spill-to -] unit-test - -[ 0 ] [ - test-live-interval-1 1 get spill-to -] unit-test - -CONSTANT: test-live-interval-2 -T{ live-interval - { start 0 } - { end 6 } - { uses V{ 0 6 } } - { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } } - { reload-from 0 } - { vreg V int-regs 0 } -} - -[ 0 ] [ - test-live-interval-2 0 get reload-from -] unit-test - -[ f ] [ - test-live-interval-2 1 get reload-from -] unit-test - [ { T{ _copy { dst 5 } { src 4 } { class int-regs } } @@ -142,8 +89,8 @@ T{ live-interval } ] [ { - T{ register->memory { from 3 } { to 4 } { reg-class int-regs } } - T{ memory->register { from 1 } { to 2 } { reg-class int-regs } } + 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 diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 7681b811c4..951e727375 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -3,7 +3,7 @@ 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.live-intervals +compiler.cfg.instructions compiler.cfg.linear-scan.assignment compiler.cfg.liveness ; IN: compiler.cfg.linear-scan.resolve @@ -14,50 +14,33 @@ TUPLE: operation from to reg-class ; SYNTAX: OPERATION: CREATE-CLASS dup save-location [ operation { } define-tuple-class ] - [ - [ scan-word scan-word ] keep - '[ - [ [ _ execute ] [ _ execute ] bi* ] - [ vreg>> reg-class>> ] - bi _ boa , - ] (( from to -- )) define-declared - ] bi ; + [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; >> -: insn-in-block? ( insn# bb -- ? ) - [ block-from ] [ block-to ] bi between? ; +OPERATION: register->memory +OPERATION: memory->register +OPERATION: register->register -: reload-from ( live-interval bb -- n/f ) - 2dup [ start>> ] dip insn-in-block? - [ drop reload-from>> ] [ 2drop f ] if ; +! 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= ; -: spill-to ( live-interval bb -- n/f ) - 2dup [ end>> ] dip insn-in-block? - [ drop spill-to>> ] [ 2drop f ] if ; - -OPERATION: memory->memory spill-to>> reload-from>> -OPERATION: register->memory reg>> reload-from>> -OPERATION: memory->register spill-to>> reg>> -OPERATION: register->register reg>> reg>> - -:: add-mapping ( bb1 bb2 li1 li2 -- ) - li2 bb2 reload-from [ - li1 bb1 spill-to - [ li1 li2 memory->memory ] - [ li1 li2 register->memory ] if +: add-mapping ( from to reg-class -- ) + over spill-slot? [ + pick spill-slot? + [ memory->memory ] + [ register->memory ] if ] [ - li1 bb1 spill-to - [ li1 li2 memory->register ] - [ li1 li2 register->register ] if + pick spill-slot? + [ memory->register ] + [ register->register ] if ] if ; -: resolve-value-data-flow ( bb to vreg -- ) - [ 2dup ] dip - live-intervals get at - [ [ block-to ] dip child-interval-at ] - [ [ block-from ] dip child-interval-at ] - bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ; +:: resolve-value-data-flow ( bb to vreg -- ) + vreg bb vreg-at-end + vreg to vreg-at-start + 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ; : compute-mappings ( bb to -- mappings ) [ @@ -67,48 +50,23 @@ OPERATION: register->register reg>> reg>> GENERIC: >insn ( operation -- ) -M: memory->memory >insn - [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ; - M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ; + [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ; + [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; M: register->register >insn [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; -GENERIC: >collision-table ( operation -- ) - -M: memory->memory >collision-table - [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ; - -M: register->memory >collision-table - [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ; - -M: memory->register >collision-table - [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ; - -M: register->register >collision-table - [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; - SYMBOL: froms SYMBOL: tos SINGLETONS: memory register ; -GENERIC: from-loc ( operation -- obj ) -M: memory->memory from-loc drop memory ; -M: register->memory from-loc drop register ; -M: memory->register from-loc drop memory ; -M: register->register from-loc drop register ; +: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; -GENERIC: to-loc ( operation -- obj ) -M: memory->memory to-loc drop memory ; -M: register->memory to-loc drop memory ; -M: memory->register to-loc drop register ; -M: register->register to-loc drop register ; +: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; : from-reg ( operation -- seq ) [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; @@ -142,7 +100,6 @@ M: register->register to-loc drop register ; dup dup associate (trace-chain) ] { } make prune reverse ; - : trace-chains ( seq -- seq' ) [ trace-chain ] map concat ; @@ -159,10 +116,10 @@ ERROR: resolve-error ; : break-cycle-n ( operations -- operations' ) split-cycle [ - [ from>> spill-temp ] + [ from>> spill-temp ] [ reg-class>> ] bi \ register->memory boa ] [ - [ to>> spill-temp swap ] + [ to>> spill-temp swap ] [ reg-class>> ] bi \ memory->register boa ] bi [ 1array ] bi@ surround ;