steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.cfg.height: clean it up a bit

db4
Slava Pestov 2010-06-22 04:14:03 -04:00
parent 75d2635c05
commit 167aff1b57
2 changed files with 48 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
basis/compiler/cfg/height/height-tests.factor Normal file
View File

@ -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

44
basis/compiler/cfg/height/height.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors math namespaces sequences kernel fry USING: accessors math namespaces sequences kernel fry
compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg compiler.cfg.registers compiler.cfg.instructions
@ -11,19 +11,17 @@ IN: compiler.cfg.height
SYMBOL: ds-height SYMBOL: ds-height
SYMBOL: rs-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 ; GENERIC: visit-insn ( insn -- )
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
M: insn compute-heights drop ;
GENERIC: normalize-height* ( insn -- insn' ) : normalize-inc-d/r ( insn stack -- )
swap n>> '[ _ + ] change ; inline
: normalize-inc-d/r ( insn stack -- insn' ) M: ##inc-d visit-insn ds-height normalize-inc-d/r ;
swap n>> '[ _ - ] change f ; inline M: ##inc-r visit-insn rs-height normalize-inc-d/r ;
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
GENERIC: loc-stack ( loc -- stack ) GENERIC: loc-stack ( loc -- stack )
@ -35,21 +33,23 @@ GENERIC: <loc> ( n stack -- loc )
M: ds-loc <loc> drop <ds-loc> ; M: ds-loc <loc> drop <ds-loc> ;
M: rs-loc <loc> drop <rs-loc> ; M: rs-loc <loc> drop <rs-loc> ;
: normalize-peek/replace ( insn -- insn' ) : normalize-peek/replace ( insn -- )
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc
drop ; inline
M: ##peek normalize-height* normalize-peek/replace ; M: ##peek visit-insn normalize-peek/replace ;
M: ##replace normalize-height* normalize-peek/replace ; M: ##replace visit-insn normalize-peek/replace ;
M: insn normalize-height* ; M: insn visit-insn drop ;
: height-step ( insns -- insns' ) : height-step ( insns -- insns' )
0 ds-height set init-height
0 rs-height set [ <reversed> [ visit-insn ] each ]
[ [ compute-heights ] each ] [
[ [ [ normalize-height* ] map sift ] with-scope ] bi [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter!
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if ds-height get [ \ ##inc-d new-insn prefix ] unless-zero
rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ; rs-height get [ \ ##inc-r new-insn prefix ] unless-zero
] bi ;
: normalize-height ( cfg -- cfg' ) : normalize-height ( cfg -- cfg' )
dup [ height-step ] simple-optimization ; dup [ height-step ] simple-optimization ;