diff --git a/basis/compiler/cfg/stacks/clearing/clearing.factor b/basis/compiler/cfg/stacks/clearing/clearing.factor index cb33617526..5df62202a5 100644 --- a/basis/compiler/cfg/stacks/clearing/clearing.factor +++ b/basis/compiler/cfg/stacks/clearing/clearing.factor @@ -1,6 +1,6 @@ USING: accessors arrays assocs combinators.short-circuit compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo -compiler.cfg.stacks compiler.cfg.stacks.map kernel math sequences ; +compiler.cfg.stacks compiler.cfg.stacks.padding kernel math sequences ; IN: compiler.cfg.stacks.clearing : state>replaces ( state -- replaces ) @@ -19,6 +19,6 @@ IN: compiler.cfg.stacks.clearing [ [ clearing-replaces ] keep suffix ] with map V{ } concat-as ; : clear-uninitialized ( cfg -- ) - [ trace-stack-state ] keep [ + [ trace-stack-state2 ] keep [ [ visit-insns ] change-instructions drop ] with each-basic-block ; diff --git a/basis/compiler/cfg/stacks/padding/padding-tests.factor b/basis/compiler/cfg/stacks/padding/padding-tests.factor new file mode 100644 index 0000000000..23721b4a63 --- /dev/null +++ b/basis/compiler/cfg/stacks/padding/padding-tests.factor @@ -0,0 +1,611 @@ +USING: accessors arrays assocs compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.stacks.padding compiler.cfg.utilities kernel sequences sorting +vectors tools.test ; +IN: compiler.cfg.stacks.padding.tests + +! classify-read: vacant locations +{ 2 2 2 } [ + { 3 { } } 2 classify-read + { 0 { } } -1 classify-read + { 3 { } } -1 classify-read +] unit-test + +! classify-read: over locations +{ 1 1 1 1 1 } [ + { 1 { 0 } } 1 classify-read + { 0 { } } 0 classify-read + { 3 { } } 4 classify-read + { 0 { } } 4 classify-read + { 1 { 0 } } 4 classify-read +] unit-test + +! classify-read: initialized locations +{ 0 0 0 } [ + { 1 { 0 } } 0 classify-read + { 2 { 0 1 2 } } 0 classify-read + { 0 { 0 1 2 } } 0 classify-read +] unit-test + +! fill-stack +{ + { 2 { 4 5 0 1 } } +} [ + { 2 { 4 5 } } fill-stack +] unit-test + +{ + { -1 { 3 4 } } +} [ + { -1 { 3 4 } } fill-stack +] unit-test + +! fill-vacancies +{ + { { 0 { } } { 2 { 0 1 } } } + { { 0 { } } { 2 { 0 1 } } } + { { 0 { -1 -2 } } { 2 { 0 1 } } } +} [ + { { 0 { } } { 2 { } } } fill-vacancies + { { 0 { } } { 2 { 0 } } } fill-vacancies + { { 0 { -1 -2 } } { 2 { 0 } } } fill-vacancies +] unit-test + +! combined-state +{ + { { 4 { } } { 2 { 0 1 } } } +} [ + V{ { { 4 { } } { 2 { 0 1 } } } } combine-states +] unit-test + +{ + { { 0 { } } { 0 { } } } +} [ + V{ } combine-states +] unit-test + +! States can't be combined if their heights are different +[ + V{ { { 3 { } } { 0 { } } } { { 8 { } } { 0 { } } } } combine-states +] [ height-mismatches? ] must-fail-with + +[ + V{ { { 4 { } } { 2 { 0 1 } } } { { 5 { 4 3 2 } } { 0 { } } } } + combine-states +] [ height-mismatches? ] must-fail-with + +! stack>vacant +{ + { 0 1 2 } + { } + { 1 } +} [ + { 3 { } } stack>vacant + { -2 { } } stack>vacant + { 3 { 0 2 } } stack>vacant +] unit-test + +! visit-insn ##inc + +! We assume that overinitialized locations are always dead. +{ + { { 0 { } } { 0 { } } } +} [ + { { 3 { 0 } } { 0 { } } } T{ ##inc { loc D -3 } } visit-insn +] unit-test + +! visit-insn ##call +{ + { { 3 { 0 1 2 } } { 0 { } } } +} [ + initial-state T{ ##call { height 3 } } visit-insn +] unit-test + + +{ + { { -1 { } } { 0 { } } } +} [ + initial-state T{ ##call { height -1 } } visit-insn +] unit-test + + +{ + { { 4 { 2 3 0 1 } } { 0 { } } } +} [ + { { 2 { 0 1 } } { 0 { } } } T{ ##call { height 2 } } visit-insn +] unit-test + +! This looks weird but is right. +{ + { { 0 { 0 1 } } { 0 { } } } +} [ + { { -2 { } } { 0 { } } } T{ ##call { height 2 } } visit-insn +] unit-test + + +! if any of the stack locations are uninitialized when ##call is +! visisted then something is wrong. ##call might gc and the +! uninitialized locations would cause a crash. +[ + { { 3 { } } { 0 { } } } T{ ##call { height 3 } } visit-insn +] [ vacant-when-calling? ] must-fail-with + +! ! Overinitialized locations can't be live when ##call is visited. They +! ! could be garbage collected in the called word so they maybe wouldn't +! ! survive. +! [ +! { { 0 { -1 -2 } } { 0 { -1 -2 } } } T{ ##call { height 0 } } visit-insn +! ] [ overinitialized-when-calling? ] must-fail-with + +! This is tricky. Normally, there should be no overinitialized +! locations before a ##call (I think). But if they are, we can at +! least be sure they are dead after the call. +{ + { { 2 { 0 1 } } { 0 { } } } +} [ + { { 2 { 0 1 -1 } } { 0 { } } } T{ ##call { height 0 } } visit-insn +] unit-test + +! visit-insn ##call-gc + +! ##call-gc ofcourse fills all uninitialized locations. +{ + { { 4 { 0 1 2 3 } } { 0 { } } } +} [ + { { 4 { } } { 0 { } } } T{ ##call-gc } visit-insn +] unit-test + +! visit-insn ##peek +{ + { { 3 { 0 } } { 0 { } } } +} [ + { { 3 { 0 } } { 0 { } } } T{ ##peek { dst 1 } { loc D 0 } } visit-insn +] unit-test + +! After a ##peek that can cause a stack underflow, it is certain that +! all stack locations are initialized. +{ + { { 0 { } } { 2 { 0 1 2 } } } + { { 2 { 0 1 2 } } { 0 { } } } +} [ + { { 0 { } } { 2 { } } } T{ ##peek { dst 1 } { loc R 2 } } visit-insn + { { 2 { } } { 0 { } } } T{ ##peek { dst 1 } { loc D 2 } } visit-insn +] unit-test + +{ + { { 2 { 0 1 } } { 2 { 0 1 2 } } } +} [ + { { 2 { } } { 2 { } } } T{ ##peek { dst 1 } { loc R 2 } } visit-insn +] unit-test + +! If the ##peek can't cause a stack underflow, then we don't have the +! same guarantees. +[ + { { 3 { } } { 0 { } } } T{ ##peek { dst 1 } { loc D 0 } } visit-insn +] [ vacant-peek? ] must-fail-with + +: following-stack-state ( insns -- state ) + T{ ##branch } suffix insns>cfg trace-stack-state2 + >alist [ first ] sort-with last second ; + +! trace-stack-state2 +{ + H{ + { + 0 + { { 0 { } } { 0 { } } } + } + { + 1 + { { 2 { } } { 0 { } } } + } + { + 2 + { { 2 { 0 1 2 } } { 0 { } } } + } + } +} [ + { + T{ ##inc f D 2 } + T{ ##peek f f D 2 } + T{ ##inc f D 0 } + } insns>cfg trace-stack-state2 +] unit-test + +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 0 { } } { 0 { } } } } + { 2 { { 0 { } } { 0 { } } } } + } +} [ + V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } + insns>cfg trace-stack-state2 +] unit-test + +! The peek "causes" the vacant locations to become populated. +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 3 { } } { 0 { } } } } + { 2 { { 3 { 0 1 2 3 } } { 0 { } } } } + } +} [ + V{ + T{ ##inc f D 3 } + T{ ##peek { loc D 3 } } + T{ ##branch } + } + insns>cfg trace-stack-state2 +] unit-test + +! Replace -1 then peek is ok. +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 0 { -1 } } { 0 { } } } } + { 2 { { 0 { -1 } } { 0 { } } } } + } +} [ + V{ + T{ ##replace { src 10 } { loc D -1 } } + T{ ##peek { loc D -1 } } + T{ ##branch } + } + insns>cfg trace-stack-state2 +] unit-test + +: cfg1 ( -- cfg ) + V{ + T{ ##inc f D 1 } + T{ ##replace { src 10 } { loc D 0 } } + } 0 insns>block + V{ + T{ ##peek { dst 37 } { loc D 0 } } + T{ ##inc f D -1 } + } 1 insns>block + 1vector >>successors block>cfg ; + +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 1 { } } { 0 { } } } } + { 2 { { 1 { 0 } } { 0 { } } } } + { 3 { { 1 { 0 } } { 0 { } } } } + } +} [ cfg1 trace-stack-state2 ] unit-test + +! Same cfg structure as the bug1021:run-test word but with +! non-datastack instructions mostly omitted. +: bug1021-cfg ( -- cfg ) + { + { 0 V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } } + { + 1 V{ + T{ ##inc f D 2 } + T{ ##replace { src 0 } { loc D 1 } } + T{ ##replace { src 0 } { loc D 0 } } + } + } + { + 2 V{ + T{ ##call { word } { height 0 } } + } + } + { + 3 V{ + T{ ##peek { dst 0 } { loc D 0 } } + T{ ##peek { dst 0 } { loc D 1 } } + T{ ##inc f D 2 } + T{ ##replace { src 0 } { loc D 2 } } + T{ ##replace { src 0 } { loc D 3 } } + T{ ##replace { src 0 } { loc D 1 } } + } + } + { + 8 V{ + T{ ##peek { dst 0 } { loc D 2 } } + T{ ##peek { dst 0 } { loc D 1 } } + T{ ##inc f D 3 } + T{ ##replace { src 0 } { loc D 0 } } + T{ ##replace { src 0 } { loc D 1 } } + T{ ##replace { src 0 } { loc D 2 } } + T{ ##replace { src 0 } { loc D 3 } } + } + } + { + 10 V{ + T{ ##inc f D -3 } + T{ ##peek { dst 0 } { loc D 0 } } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + } + } + } [ over insns>block ] assoc-map dup + { { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ; + +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 0 { } } { 0 { } } } } + { 2 { { 0 { } } { 0 { } } } } + { 3 { { 0 { } } { 0 { } } } } + { 4 { { 2 { } } { 0 { } } } } + { 5 { { 2 { 1 } } { 0 { } } } } + { 6 { { 2 { 1 0 } } { 0 { } } } } + { 7 { { 2 { 1 0 } } { 0 { } } } } + { 8 { { 2 { 1 0 } } { 0 { } } } } + { 9 { { 2 { 1 0 } } { 0 { } } } } + { 10 { { 4 { 3 2 } } { 0 { } } } } + { 11 { { 4 { 3 2 } } { 0 { } } } } + { 12 { { 4 { 3 2 } } { 0 { } } } } + { 13 { { 4 { 3 2 1 } } { 0 { } } } } + { 14 { { 4 { 3 2 1 } } { 0 { } } } } + { 15 { { 4 { 3 2 1 } } { 0 { } } } } + { 16 { { 7 { 6 5 4 } } { 0 { } } } } + { 17 { { 7 { 6 5 4 0 } } { 0 { } } } } + { 18 { { 7 { 6 5 4 0 1 } } { 0 { } } } } + { 19 { { 7 { 6 5 4 0 1 2 } } { 0 { } } } } + { 20 { { 7 { 6 5 4 0 1 2 3 } } { 0 { } } } } + { 21 { { 4 { 3 2 1 0 } } { 0 { } } } } + { 22 { { 4 { 3 2 1 0 } } { 0 { } } } } + } +} [ + bug1021-cfg trace-stack-state2 +] unit-test + +! Same cfg structure as the bug1289:run-test word but with +! non-datastack instructions mostly omitted. +: bug1289-cfg ( -- cfg ) + { + { 0 V{ } } + { + 1 V{ + T{ ##inc f D 3 } + T{ ##replace { src 0 } { loc D 2 } } + T{ ##replace { src 0 } { loc D 0 } } + T{ ##replace { src 0 } { loc D 1 } } + } + } + { + 2 V{ + T{ ##call { word } { height -1 } } + } + } + { + 3 V{ + T{ ##peek { dst 0 } { loc D 1 } } + T{ ##peek { dst 0 } { loc D 0 } } + T{ ##inc f D 1 } + T{ ##inc f R 1 } + T{ ##replace { src 0 } { loc R 0 } } + } + } + { + 4 V{ } + } + { + 5 V{ + T{ ##inc f D -2 } + T{ ##inc f R 5 } + T{ ##replace { src 0 } { loc R 3 } } + T{ ##replace { src 0 } { loc D 0 } } + T{ ##replace { src 0 } { loc R 4 } } + T{ ##replace { src 0 } { loc R 2 } } + T{ ##replace { src 0 } { loc R 1 } } + T{ ##replace { src 0 } { loc R 0 } } + } + } + { + 6 V{ + T{ ##call { word f } { height 0 } } + } + } + { + 7 V{ + T{ ##peek { dst 0 } { loc D 0 } } + T{ ##peek { dst 0 } { loc R 3 } } + T{ ##peek { dst 0 } { loc R 2 } } + T{ ##peek { dst 0 } { loc R 1 } } + T{ ##peek { dst 0 } { loc R 0 } } + T{ ##peek { dst 0 } { loc R 4 } } + T{ ##inc f D 2 } + T{ ##inc f R -5 } + } + } + { 8 V{ } } + { 9 V{ } } + { 10 V{ } } + { + 11 V{ + T{ ##call-gc } + } + } + { + 12 V{ + T{ ##peek { dst 0 } { loc R 0 } } + T{ ##inc f D -3 } + T{ ##inc f D 1 } + T{ ##inc f R -1 } + T{ ##replace { src 0 } { loc D 0 } } + } + } + { + 13 V{ } + } + } [ over insns>block ] assoc-map dup + { + { 0 1 } + { 1 2 } + { 2 3 } + { 3 4 } + { 4 9 } + { 5 6 } + { 6 7 } + { 7 8 } + { 8 9 } + { 9 5 } + { 9 10 } + { 10 12 } + { 10 11 } + { 11 12 } + { 12 13 } + } make-edges 0 of block>cfg ; + +{ + H{ + { 0 { { 0 { } } { 0 { } } } } + { 1 { { 3 { } } { 0 { } } } } + { 2 { { 3 { 2 } } { 0 { } } } } + { 3 { { 3 { 2 0 } } { 0 { } } } } + { 4 { { 3 { 2 0 1 } } { 0 { } } } } + { 5 { { 2 { 1 0 } } { 0 { } } } } + { 6 { { 2 { 1 0 } } { 0 { } } } } + { 7 { { 2 { 1 0 } } { 0 { } } } } + { 8 { { 3 { 2 1 } } { 0 { } } } } + { 9 { { 3 { 2 1 } } { 1 { } } } } + { 10 { { 3 { 2 } } { 1 { 0 } } } } + { 11 { { 1 { 0 } } { 1 { 0 } } } } + { 12 { { 1 { 0 } } { 6 { 5 } } } } + { 13 { { 1 { 0 } } { 6 { 5 3 } } } } + { 14 { { 1 { 0 } } { 6 { 5 3 } } } } + { 15 { { 1 { 0 } } { 6 { 5 3 4 } } } } + { 16 { { 1 { 0 } } { 6 { 5 3 4 2 } } } } + { 17 { { 1 { 0 } } { 6 { 5 3 4 2 1 } } } } + { 18 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 19 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 20 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 21 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 22 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 23 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 24 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 25 { { 1 { 0 } } { 6 { 5 3 4 2 1 0 } } } } + { 26 { { 3 { 2 } } { 6 { 5 3 4 2 1 0 } } } } + { 27 { { 3 { 2 } } { 1 { 0 } } } } + { 28 { { 3 { 2 } } { 1 { 0 } } } } + { 29 { { 3 { 2 } } { 1 { 0 } } } } + { 30 { { 0 { } } { 1 { 0 } } } } + { 31 { { 1 { } } { 1 { 0 } } } } + { 32 { { 1 { } } { 0 { } } } } + } +} [ bug1289-cfg trace-stack-state2 ] unit-test + +! following-stack-state +{ + { { 0 { } } { 0 { } } } +} [ V{ } following-stack-state ] unit-test + +{ + { { 1 { } } { 0 { } } } +} [ V{ T{ ##inc f D 1 } } following-stack-state ] unit-test + +{ + { { 0 { } } { 1 { } } } +} [ V{ T{ ##inc f R 1 } } following-stack-state ] unit-test + +! Here the peek refers to a parameter of the word. +{ + { { 0 { 25 } } { 0 { } } } +} [ + V{ + T{ ##peek { loc D 25 } } + } following-stack-state +] unit-test + +! Should be ok because the value was at 0 when the gc ran. +{ + { { -1 { -1 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + T{ ##inc f D -1 } + T{ ##peek { loc D -1 } } + } following-stack-state +] unit-test + +{ + { { 0 { 0 1 2 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##replace { src 10 } { loc D 1 } } + T{ ##replace { src 10 } { loc D 2 } } + } following-stack-state +] unit-test + +{ + { { 1 { 1 0 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc f D 1 } + T{ ##replace { src 10 } { loc D 0 } } + } following-stack-state +] unit-test + +{ + { { 0 { 0 } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc f D 1 } + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc f D -1 } + } following-stack-state +] unit-test + +{ + { { 0 { } } { 0 { } } } +} [ + V{ + T{ ##inc f D 1 } + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc f D -1 } + } following-stack-state +] unit-test + +! ##call clears the overinitialized slots. +{ + { { -1 { } } { 0 { } } } +} [ + V{ + T{ ##replace { src 10 } { loc D 0 } } + T{ ##inc f D -1 } + T{ ##call { height 0 } } + } following-stack-state +] unit-test + +! Should not be ok because the value wasn't initialized when gc ran. +[ + V{ + T{ ##inc f D 1 } + T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } } + T{ ##peek { loc D 0 } } + } following-stack-state +] [ vacant-peek? ] must-fail-with + +[ + V{ + T{ ##inc f D 1 } + T{ ##peek { loc D 0 } } + } following-stack-state +] [ vacant-peek? ] must-fail-with + +[ + V{ + T{ ##inc f R 1 } + T{ ##peek { loc R 0 } } + } following-stack-state +] [ vacant-peek? ] must-fail-with + + + + + + + + + +! ! (scan-c-args) run-test flip + + +! seem good: (gamma-random-float>1) diff --git a/basis/compiler/cfg/stacks/padding/padding.factor b/basis/compiler/cfg/stacks/padding/padding.factor new file mode 100644 index 0000000000..18f86ce3e4 --- /dev/null +++ b/basis/compiler/cfg/stacks/padding/padding.factor @@ -0,0 +1,127 @@ +! Copyright (C) 2015 Björn Lindqvist. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs compiler.cfg.dataflow-analysis +compiler.cfg.instructions compiler.cfg.linearization compiler.cfg.predecessors +compiler.cfg.registers compiler.cfg.stacks compiler.cfg.stacks.local +compiler.cfg.stacks.global fry grouping kernel math math.order namespaces +sequences ; +QUALIFIED: sets +IN: compiler.cfg.stacks.padding + +ERROR: overinitialized-when-calling seq ; +ERROR: vacant-when-calling seq ; + +: safe-iota ( n -- seq ) + 0 max iota ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !! Stack +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +ERROR: height-mismatches seq ; + +: register-write ( n stack -- stack' ) + first2 rot suffix sets:members 2array ; + +: adjust-stack ( n stack -- stack' ) + first2 pick '[ _ + ] map [ + ] dip 2array ; + +: stack>vacant ( stack -- seq ) + first2 [ safe-iota ] dip sets:diff ; + +: combine-stacks ( stacks -- stack ) + [ [ first ] map dup all-equal? [ first ] [ height-mismatches ] if ] + [ [ second ] map refine ] bi 2array ; + +: fill-stack ( stack -- stack' ) + first2 over safe-iota sets:union 2array ; + +: classify-read ( stack n -- val ) + swap 2dup second member? [ 2drop 0 ] [ first >= [ 1 ] [ 2 ] if ] if ; + +: push-items ( n stack -- stack' ) + first2 pick '[ _ + ] map pick safe-iota sets:union [ + ] dip 2array ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! !! States +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +CONSTANT: initial-state { { 0 { } } { 0 { } } } + +: apply-stack-op ( state insn quote: ( n stack -- stack' ) -- state' ) + [ [ first2 ] dip loc>> >loc< ] dip + [ '[ rot @ swap ] ] [ '[ swap @ ] ] bi if 2array ; inline + +: combine-states ( states -- state ) + [ initial-state ] [ flip [ combine-stacks ] map ] if-empty ; + +: mark-location ( state insn -- state' ) + [ register-write ] apply-stack-op ; + +: ensure-no-vacant ( state -- ) + [ stack>vacant ] map dup { { } { } } = + [ drop ] [ vacant-when-calling ] if ; + +: ensure-no-overinitialized ( state -- ) + [ second [ 0 < ] filter ] map dup { { } { } } = + [ drop ] [ overinitialized-when-calling ] if ; + +: fill-vacancies ( state -- state' ) + [ fill-stack ] map ; + +GENERIC: visit-insn ( state insn -- state' ) + +M: ##inc visit-insn ( state insn -- state' ) + [ adjust-stack ] apply-stack-op + [ first2 [ 0 >= ] filter 2array ] map ; + +M: ##replace-imm visit-insn mark-location ; +M: ##replace visit-insn mark-location ; + +M: ##call visit-insn ( state insn -- state' ) + over ensure-no-vacant + height>> swap first2 [ push-items ] dip 2array + [ first2 [ 0 >= ] filter 2array ] map ; + +M: ##call-gc visit-insn ( state insn -- state' ) + drop dup ensure-no-overinitialized fill-vacancies ; + +M: gc-map-insn visit-insn ( state insn -- state' ) + drop ; + +ERROR: vacant-peek insn ; + +: underflowable-peek? ( state peek -- ? ) + 2dup loc>> >loc< swap [ 0 1 ? swap nth ] dip classify-read + dup 2 = [ drop vacant-peek ] [ 2nip 1 = ] if ; + +M: ##peek visit-insn ( state insn -- state ) + 2dup underflowable-peek? [ [ fill-vacancies ] dip ] when mark-location ; + +M: insn visit-insn ( state insn -- state' ) + drop ; + +FORWARD-ANALYSIS: padding + +SYMBOL: stack-record + +: register-stack-state ( state insn -- ) + insn#>> stack-record get set-at ; + +: visit-insns ( insns state -- state' ) + [ [ register-stack-state ] [ visit-insn ] 2bi ] reduce ; + +M: padding-analysis transfer-set ( in-set bb dfa -- out-set ) + drop instructions>> swap visit-insns ; + +M: padding-analysis ignore-block? ( bb dfa -- ? ) + 2drop f ; + +M: padding-analysis join-sets ( sets bb dfa -- set ) + 2drop combine-states ; + +: uniquely-number-instructions ( cfg -- ) + cfg>insns [ swap insn#<< ] each-index ; + +: trace-stack-state2 ( cfg -- assoc ) + H{ } clone stack-record set + [ uniquely-number-instructions ] [ compute-padding-sets ] bi + stack-record get ; diff --git a/basis/compiler/cfg/stacks/vacant/vacant-docs.factor b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor index 45e8a5f634..c102118397 100644 --- a/basis/compiler/cfg/stacks/vacant/vacant-docs.factor +++ b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor @@ -1,4 +1,4 @@ -USING: compiler.cfg compiler.cfg.instructions compiler.cfg.stacks.map +USING: compiler.cfg compiler.cfg.instructions compiler.cfg.stacks.padding help.markup help.syntax sequences strings ; IN: compiler.cfg.stacks.vacant @@ -19,7 +19,7 @@ HELP: fill-gc-maps HELP: state>gc-data { $values { "state" sequence } { "gc-data" sequence } } -{ $description "Takes a stack state on the format given by " { $link trace-stack-state } " and emits an array containing two bit-patterns with locations on the data and retain stacks to scrub." } ; +{ $description "Takes a stack state on the format given by " { $link trace-stack-state2 } " and emits an array containing two bit-patterns with locations on the data and retain stacks to scrub." } ; HELP: vacant>bits { $values diff --git a/basis/compiler/cfg/stacks/vacant/vacant.factor b/basis/compiler/cfg/stacks/vacant/vacant.factor index 2a31475bc9..4f9f26c3d5 100644 --- a/basis/compiler/cfg/stacks/vacant/vacant.factor +++ b/basis/compiler/cfg/stacks/vacant/vacant.factor @@ -1,26 +1,20 @@ USING: accessors arrays assocs compiler.cfg.instructions -compiler.cfg.linearization compiler.cfg.stacks.map fry kernel math sequences ; +compiler.cfg.linearization compiler.cfg.stacks.padding fry kernel math +sequences ; IN: compiler.cfg.stacks.vacant -! ! Utils -: write-slots ( tuple values slots -- ) - [ execute( x y -- z ) ] 2each drop ; - : vacant>bits ( vacant -- bits ) [ { } ] [ dup supremum 1 + 1 [ '[ _ 0 -rot set-nth ] each ] keep ] if-empty ; -! Operations on the analysis state : state>gc-data ( state -- gc-data ) [ stack>vacant vacant>bits ] map ; : set-gc-map ( state gc-map -- ) - swap state>gc-data { >>scrub-d >>scrub-r } write-slots ; - ! swap state>gc-data { { } { } } append - ! { >>scrub-d >>scrub-r >>check-d >>check-r } write-slots ; + swap state>gc-data first2 -rot >>scrub-d swap >>scrub-r drop ; : fill-gc-maps ( cfg -- ) - [ trace-stack-state ] [ cfg>insns [ gc-map-insn? ] filter ] bi + [ trace-stack-state2 ] [ cfg>insns [ gc-map-insn? ] filter ] bi [ [ insn#>> of ] [ gc-map>> ] bi set-gc-map ] with each ;