diff --git a/basis/compiler/cfg/height/height-tests.factor b/basis/compiler/cfg/height/height-tests.factor new file mode 100644 index 0000000000..e4b290b22a --- /dev/null +++ b/basis/compiler/cfg/height/height-tests.factor @@ -0,0 +1,26 @@ +USING: compiler.cfg.height compiler.cfg.instructions +compiler.cfg.registers tools.test ; +IN: compiler.cfg.height.tests + +[ + V{ + T{ ##inc-r f -1 f } + T{ ##inc-d f 4 f } + T{ ##peek f 0 D 4 f } + T{ ##peek f 1 D 0 f } + T{ ##replace f 0 R -1 f } + T{ ##replace f 1 R 0 f } + T{ ##peek f 2 D 0 f } + } +] [ + V{ + T{ ##peek f 0 D 0 } + T{ ##inc-d f 3 } + T{ ##peek f 1 D -1 } + T{ ##replace f 0 R 0 } + T{ ##inc-r f -1 } + T{ ##replace f 1 R 0 } + T{ ##inc-d f 1 } + T{ ##peek f 2 D 0 } + } height-step +] unit-test diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor index 4471508877..8594e6d9b5 100644 --- a/basis/compiler/cfg/height/height.factor +++ b/basis/compiler/cfg/height/height.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math namespaces sequences kernel fry compiler.cfg compiler.cfg.registers compiler.cfg.instructions @@ -11,19 +11,17 @@ IN: compiler.cfg.height SYMBOL: ds-height SYMBOL: rs-height -GENERIC: compute-heights ( insn -- ) +: init-height ( -- ) + 0 ds-height set + 0 rs-height set ; -M: ##inc-d compute-heights n>> ds-height [ + ] change ; -M: ##inc-r compute-heights n>> rs-height [ + ] change ; -M: insn compute-heights drop ; +GENERIC: visit-insn ( insn -- ) -GENERIC: normalize-height* ( insn -- insn' ) +: normalize-inc-d/r ( insn stack -- ) + swap n>> '[ _ + ] change ; inline -: normalize-inc-d/r ( insn stack -- insn' ) - swap n>> '[ _ - ] change f ; inline - -M: ##inc-d normalize-height* ds-height normalize-inc-d/r ; -M: ##inc-r normalize-height* rs-height normalize-inc-d/r ; +M: ##inc-d visit-insn ds-height normalize-inc-d/r ; +M: ##inc-r visit-insn rs-height normalize-inc-d/r ; GENERIC: loc-stack ( loc -- stack ) @@ -35,21 +33,23 @@ GENERIC: ( n stack -- loc ) M: ds-loc drop ; M: rs-loc drop ; -: normalize-peek/replace ( insn -- insn' ) - [ [ [ n>> ] [ loc-stack get ] bi + ] keep ] change-loc ; inline +: normalize-peek/replace ( insn -- ) + [ [ [ n>> ] [ loc-stack get ] bi + ] keep ] change-loc + drop ; inline -M: ##peek normalize-height* normalize-peek/replace ; -M: ##replace normalize-height* normalize-peek/replace ; +M: ##peek visit-insn normalize-peek/replace ; +M: ##replace visit-insn normalize-peek/replace ; -M: insn normalize-height* ; +M: insn visit-insn drop ; : height-step ( insns -- insns' ) - 0 ds-height set - 0 rs-height set - [ [ compute-heights ] each ] - [ [ [ normalize-height* ] map sift ] with-scope ] bi - ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if - rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ; + init-height + [ [ visit-insn ] each ] + [ + [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter! + ds-height get [ \ ##inc-d new-insn prefix ] unless-zero + rs-height get [ \ ##inc-r new-insn prefix ] unless-zero + ] bi ; : normalize-height ( cfg -- cfg' ) dup [ height-step ] simple-optimization ;