diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor index 090283410f..8435a231e6 100644 --- a/basis/compiler/cfg/gc-checks/gc-checks.factor +++ b/basis/compiler/cfg/gc-checks/gc-checks.factor @@ -10,7 +10,7 @@ IN: compiler.cfg.gc-checks : insert-gc-check ( basic-block -- ) dup gc? [ - [ i i f f \ ##gc new-insn prefix ] change-instructions drop + [ i i f \ ##gc new-insn prefix ] change-instructions drop ] [ drop ] if ; : insert-gc-checks ( cfg -- cfg' ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 8e2d2ff75e..56f0452d1a 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -220,7 +220,7 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; -INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ; +INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ; ! Instructions used by machine IR only. INSN: _prologue stack-frame ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 0956b7263f..0ade81311a 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -105,7 +105,7 @@ ERROR: already-reloaded ; GENERIC: assign-registers-in-insn ( insn -- ) : register-mapping ( live-intervals -- alist ) - [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ; + [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ; : all-vregs ( insn -- vregs ) [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; @@ -130,19 +130,22 @@ M: vreg-insn assign-registers-in-insn register-mapping >>regs drop ; -: compute-live-registers ( insn -- regs ) +: compute-live-registers ( insn -- assoc ) [ active-intervals ] [ temp-vregs ] bi '[ vreg>> _ memq? not ] filter register-mapping ; -: compute-live-spill-slots ( -- spill-slots ) +: compute-live-spill-slots ( -- assocs ) spill-slots get values - [ [ vreg>> swap ] { } assoc-map-as ] map concat ; + [ [ vreg>> swap ] H{ } assoc-map-as ] map ; + +: compute-live-values ( insn -- assoc ) + [ compute-live-spill-slots ] dip compute-live-registers suffix + assoc-combine ; M: ##gc assign-registers-in-insn dup call-next-method - dup compute-live-registers >>live-registers - compute-live-spill-slots >>live-spill-slots + dup compute-live-values >>live-values drop ; M: insn assign-registers-in-insn drop ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 8165553a28..15e7cef553 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -57,41 +57,31 @@ M: ##dispatch linearize-insn [ successors>> [ number>> _dispatch-label ] each ] bi* ; -: gc-root-registers ( n live-registers -- n ) +: (compute-gc-roots) ( n live-values -- n ) [ - [ second 2array , ] - [ first reg-class>> reg-size + ] - 2bi - ] each ; + [ nip 2array , ] + [ drop reg-class>> reg-size + ] + 3bi + ] assoc-each ; -: gc-root-spill-slots ( n live-spill-slots -- n ) +: oop-values ( regs -- regs' ) + [ drop reg-class>> int-regs eq? ] assoc-filter ; + +: data-values ( regs -- regs' ) + [ drop reg-class>> double-float-regs eq? ] assoc-filter ; + +: compute-gc-roots ( live-values -- alist ) [ - dup first reg-class>> int-regs eq? [ - [ second 2array , ] - [ first reg-class>> reg-size + ] - 2bi - ] [ drop ] if - ] each ; - -: oop-registers ( regs -- regs' ) - [ first reg-class>> int-regs eq? ] filter ; - -: data-registers ( regs -- regs' ) - [ first reg-class>> double-float-regs eq? ] filter ; - -:: compute-gc-roots ( live-registers live-spill-slots -- alist ) - [ - 0 + [ 0 ] dip ! we put float registers last; the GC doesn't actually scan them - live-registers oop-registers gc-root-registers - live-spill-slots gc-root-spill-slots - live-registers data-registers gc-root-registers + [ oop-values (compute-gc-roots) ] + [ data-values (compute-gc-roots) ] bi drop ] { } make ; -: count-gc-roots ( live-registers live-spill-slots -- n ) +: count-gc-roots ( live-values -- n ) ! Size of GC root area, minus the float registers - [ oop-registers length ] bi@ + ; + oop-values assoc-size ; M: ##gc linearize-insn nip @@ -99,11 +89,11 @@ M: ##gc linearize-insn [ temp1>> ] [ temp2>> ] [ - [ live-registers>> ] [ live-spill-slots>> ] bi + live-values>> [ compute-gc-roots ] [ count-gc-roots ] [ gc-roots-size ] - 2tri + tri ] tri _gc ] with-regs ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 5cb5762b78..9eb6d27521 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -34,8 +34,8 @@ spill-counts ; : gc-root-offset ( n -- n' ) gc-root-base + ; -: gc-roots-size ( live-registers live-spill-slots -- n ) - [ keys [ reg-class>> reg-size ] sigma ] bi@ + ; +: gc-roots-size ( live-values -- n ) + keys [ reg-class>> reg-size ] sigma ; : (stack-frame-size) ( stack-frame -- n ) [