diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 3664f58b1e..5cc964a197 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -16,10 +16,16 @@ IN: compiler.cfg.linear-scan.assignment ! This contains both active and inactive intervals; any interval ! such that start <= insn# <= end is in this set. -SYMBOL: pending-intervals +SYMBOL: pending-interval-heap +SYMBOL: pending-interval-assoc -: add-active ( live-interval -- ) - dup end>> pending-intervals get heap-push ; +: add-pending ( live-interval -- ) + [ dup end>> pending-interval-heap get heap-push ] + [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ] + bi ; + +: remove-pending ( live-interval -- ) + vreg>> pending-interval-assoc get delete-at ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -37,7 +43,8 @@ SYMBOL: register-live-ins SYMBOL: register-live-outs : init-assignment ( live-intervals -- ) - pending-intervals set + pending-interval-heap set + H{ } clone pending-interval-assoc set unhandled-intervals set H{ } clone register-live-ins set H{ } clone register-live-outs set @@ -49,16 +56,19 @@ SYMBOL: register-live-outs : handle-spill ( live-interval -- ) dup spill-to>> [ insert-spill ] [ drop ] if ; +: expire-interval ( live-interval -- ) + [ remove-pending ] [ handle-spill ] bi ; + : (expire-old-intervals) ( n heap -- ) dup heap-empty? [ 2drop ] [ 2dup heap-peek nip <= [ 2drop ] [ - dup heap-pop drop handle-spill + dup heap-pop drop expire-interval (expire-old-intervals) ] if ] if ; : expire-old-intervals ( n -- ) - pending-intervals get (expire-old-intervals) ; + pending-interval-heap get (expire-old-intervals) ; : insert-reload ( live-interval -- ) [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; @@ -66,45 +76,32 @@ SYMBOL: register-live-outs : handle-reload ( live-interval -- ) dup reload-from>> [ insert-reload ] [ drop ] if ; -: activate-new-intervals ( n -- ) - #! Any live intervals which start on the current instruction - #! are added to the active set. - unhandled-intervals get dup heap-empty? [ 2drop ] [ - 2dup heap-peek drop start>> = [ - heap-pop drop - [ add-active ] [ handle-reload ] bi - activate-new-intervals +: activate-interval ( live-interval -- ) + [ add-pending ] [ handle-reload ] bi ; + +: (activate-new-intervals) ( n heap -- ) + dup heap-empty? [ 2drop ] [ + 2dup heap-peek nip = [ + dup heap-pop drop activate-interval + (activate-new-intervals) ] [ 2drop ] if ] if ; +: activate-new-intervals ( n -- ) + unhandled-intervals get (activate-new-intervals) ; + : prepare-insn ( n -- ) [ expire-old-intervals ] [ activate-new-intervals ] bi ; GENERIC: assign-registers-in-insn ( insn -- ) -: register-mapping ( live-intervals -- alist ) - [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ; - : all-vregs ( insn -- vregs ) [ [ temp-vregs ] [ uses-vregs ] bi append ] [ defs-vreg ] bi [ suffix ] when* ; -SYMBOL: check-assignment? - -ERROR: overlapping-registers intervals ; - -: check-assignment ( intervals -- ) - dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter - dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ; - -: active-intervals ( n -- intervals ) - pending-intervals get heap-values [ covers? ] with filter - check-assignment? get [ dup check-assignment ] when ; - M: vreg-insn assign-registers-in-insn - dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi - extract-keys >>regs drop ; + dup all-vregs pending-interval-assoc get extract-keys >>regs drop ; M: ##gc assign-registers-in-insn ! This works because ##gc is always the first instruction @@ -115,33 +112,22 @@ M: ##gc assign-registers-in-insn M: insn assign-registers-in-insn drop ; -: compute-live-spill-slots ( vregs -- assoc ) - spill-slots get '[ _ at dup [ ] when ] assoc-map ; - -: compute-live-registers ( n -- assoc ) - active-intervals register-mapping ; - -ERROR: bad-live-values live-values ; - -: check-live-values ( assoc -- assoc ) - check-assignment? get [ - dup values [ not ] any? [ bad-live-values ] when - ] when ; - -: compute-live-values ( vregs n -- assoc ) +: compute-live-values ( vregs -- assoc ) ! If a live vreg is not in active or inactive, then it must have been ! spilled. - [ compute-live-spill-slots ] [ compute-live-registers ] bi* - assoc-union check-live-values ; + dup assoc-empty? [ + pending-interval-assoc get + '[ _ ?at [ ] [ spill-slots get at ] if ] assoc-map + ] unless ; : begin-block ( bb -- ) dup basic-block set dup block-from activate-new-intervals - [ [ live-in ] [ block-from ] bi compute-live-values ] keep + [ live-in compute-live-values ] keep register-live-ins get set-at ; : end-block ( bb -- ) - [ [ live-out ] [ block-to ] bi compute-live-values ] keep + [ live-out compute-live-values ] keep register-live-outs get set-at ; ERROR: bad-vreg vreg ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 7362d185b4..1673b1b365 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -21,10 +21,7 @@ compiler.cfg.linear-scan.allocation.splitting compiler.cfg.linear-scan.allocation.spilling compiler.cfg.linear-scan.debugger ; -FROM: compiler.cfg.linear-scan.assignment => check-assignment? ; - check-allocation? on -check-assignment? on check-numbering? on [