diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index efcb9251b3..48c74bad04 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -54,13 +54,12 @@ IN: compiler.cfg.liveness.tests ] unit-test ! fill-gc-map -{ H{ } } [ +{ } [ f representations set H{ } clone T{ gc-map } fill-gc-map ] unit-test { - H{ { 48 48 } } T{ gc-map { gc-roots { 48 } } { derived-roots V{ } } } } [ H{ { 48 tagged-rep } } representations set @@ -70,16 +69,12 @@ IN: compiler.cfg.liveness.tests ! kill-defs { H{ } } [ - H{ } T{ ##peek f 37 D 0 0 } kill-defs + H{ } dup T{ ##peek f 37 D 0 0 } kill-defs ] unit-test { H{ { 3 3 } } } [ H{ { 37 99 } { 99 99 } { 2 99 } } leader-map set - H{ { 37 37 } { 3 3 } } T{ ##peek f 2 D 0 0 } kill-defs -] unit-test - -{ t } [ - H{ { 123 123 } } clone T{ ##peek f 7 D 0 } dupd kill-defs eq? + H{ { 37 37 } { 3 3 } } dup T{ ##peek f 2 D 0 0 } kill-defs ] unit-test ! lookup-base-pointer @@ -97,6 +92,14 @@ IN: compiler.cfg.liveness.tests 456 T{ ##peek f 123 D 0 } lookup-base-pointer* ] unit-test +! transfer-liveness +{ + H{ { 37 37 } } +} [ + H{ } clone dup { T{ ##replace f 37 D 1 6 } T{ ##peek f 37 D 0 0 } } + transfer-liveness +] unit-test + ! visit-gc-root { V{ } HS{ 48 } } [ H{ { 48 tagged-rep } } representations set @@ -112,12 +115,24 @@ IN: compiler.cfg.liveness.tests ! visit-insn { H{ } } [ - H{ } clone T{ ##peek f 0 D 0 } visit-insn + H{ } clone [ T{ ##peek f 0 D 0 } visit-insn ] keep ] unit-test { H{ { 48 48 } { 37 37 } } } [ H{ { 48 tagged-rep } } representations set - H{ { 48 48 } } clone T{ ##replace f 37 D 1 6 } visit-insn + H{ { 48 48 } } clone [ T{ ##replace f 37 D 1 6 } visit-insn ] keep +] unit-test + +{ + T{ ##call-gc + { gc-map + T{ gc-map { gc-roots { 93 } } { derived-roots V{ } } } + } + } +} [ + H{ { 93 tagged-rep } } representations set + H{ { 93 93 } } clone T{ ##call-gc f T{ gc-map } } + [ visit-insn ] keep ] unit-test : test-liveness ( -- ) diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index ecb9c08164..16e22ecaff 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -26,17 +26,18 @@ SYMBOL: edge-live-ins SYMBOL: base-pointers -GENERIC: visit-insn ( live-set insn -- live-set ) +GENERIC: visit-insn ( live-set insn -- ) -: kill-defs ( live-set insn -- live-set ) +! This would be much better if live-set was a real set +: kill-defs ( live-set insn -- ) defs-vregs [ ?leader ] map - '[ drop ?leader _ in? not ] assoc-filter! ; inline + '[ drop ?leader _ in? not ] assoc-filter! drop ; inline -: gen-uses ( live-set insn -- live-set ) - uses-vregs [ over conjoin ] each ; inline +: gen-uses ( live-set insn -- ) + uses-vregs [ swap conjoin ] with each ; inline -M: vreg-insn visit-insn ( live-set insn -- live-set ) - [ kill-defs ] [ gen-uses ] bi ; +M: vreg-insn visit-insn ( live-set insn -- ) + [ kill-defs ] [ gen-uses ] 2bi ; DEFER: lookup-base-pointer @@ -96,19 +97,19 @@ M: vreg-insn lookup-base-pointer* 2drop f ; [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep members ; -: fill-gc-map ( live-set gc-map -- live-set ) - [ representations get [ dup gc-roots ] [ f f ] if ] dip +: fill-gc-map ( live-set gc-map -- ) + [ representations get [ gc-roots ] [ drop f f ] if ] dip [ gc-roots<< ] [ derived-roots<< ] bi ; -M: gc-map-insn visit-insn ( live-set insn -- live-set ) - [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] tri ; +M: gc-map-insn visit-insn ( live-set insn -- ) + [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ; M: ##phi visit-insn kill-defs ; -M: insn visit-insn drop ; +M: insn visit-insn 2drop ; -: transfer-liveness ( live-set instructions -- live-set' ) - [ clone ] [ ] bi* [ visit-insn ] each ; +: transfer-liveness ( live-set insns -- ) + [ visit-insn ] with each ; SYMBOL: work-list @@ -116,7 +117,7 @@ SYMBOL: work-list work-list get push-all-front ; : compute-live-in ( basic-block -- live-in ) - [ live-out ] keep instructions>> transfer-liveness ; + [ live-out clone dup ] keep instructions>> transfer-liveness ; : compute-edge-live-in ( basic-block -- edge-live-in ) H{ } clone [