94 lines
2.6 KiB
Factor
94 lines
2.6 KiB
Factor
! Copyright (C) 2008, 2011 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors assocs classes.tuple compiler.cfg
|
|
compiler.cfg.builder compiler.cfg.finalization compiler.cfg.gc-checks
|
|
compiler.cfg.instructions compiler.cfg.linearization
|
|
compiler.cfg.optimizer compiler.cfg.registers
|
|
compiler.cfg.representations compiler.cfg.save-contexts
|
|
compiler.cfg.utilities compiler.tree.builder compiler.tree.optimizer
|
|
formatting fry io kernel math namespaces prettyprint quotations
|
|
sequences strings words ;
|
|
IN: compiler.cfg.debugger
|
|
|
|
GENERIC: test-builder ( quot -- cfgs )
|
|
|
|
: build-optimized-tree ( callable/word -- tree )
|
|
reset-vreg-counter
|
|
build-tree optimize-tree ;
|
|
|
|
M: callable test-builder
|
|
build-optimized-tree gensym build-cfg ;
|
|
|
|
M: word test-builder
|
|
[ build-optimized-tree ] keep build-cfg ;
|
|
|
|
: run-passes ( cfgs passes -- cfgs' )
|
|
'[ dup cfg set dup _ apply-passes ] map ; inline
|
|
|
|
: test-ssa ( quot -- cfgs )
|
|
test-builder { optimize-cfg } run-passes ;
|
|
|
|
: test-flat ( quot -- cfgs )
|
|
test-builder {
|
|
optimize-cfg
|
|
select-representations
|
|
insert-gc-checks
|
|
insert-save-contexts
|
|
} run-passes ;
|
|
|
|
: test-regs ( quot -- cfgs )
|
|
test-builder { optimize-cfg finalize-cfg } run-passes ;
|
|
|
|
GENERIC: insn. ( insn -- )
|
|
|
|
M: ##phi insn.
|
|
clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
|
|
call-next-method ;
|
|
|
|
! XXX: pprint on a string prints the double quotes.
|
|
! This will cause graphviz to choke, so print without quotes.
|
|
: insn-number. ( n -- )
|
|
dup integer? [ "%4d " printf ] [ drop " " printf ] if ;
|
|
|
|
M: insn insn. ( insn -- )
|
|
tuple>array unclip-last insn-number. [
|
|
dup string? [ ] [ unparse ] if
|
|
] map " " join write nl ;
|
|
|
|
: block-header. ( bb -- )
|
|
[ number>> ] [ kill-block?>> "(k)" "" ? ] bi
|
|
"=== Basic block #%d %s\n\n" printf ;
|
|
|
|
: instructions. ( bb -- )
|
|
instructions>> [ insn. ] each nl ;
|
|
|
|
: successors. ( bb -- )
|
|
successors>> [
|
|
[ number>> unparse ] map ", " join
|
|
"Successors: %s\n\n" printf
|
|
] unless-empty ;
|
|
|
|
: block. ( bb -- )
|
|
[ block-header. ] [ instructions. ] [ successors. ] tri ;
|
|
|
|
: cfg-header. ( cfg -- )
|
|
[ word>> ] [ label>> ] bi "=== word: %u, label: %u\n\n" printf ;
|
|
|
|
: blocks. ( cfg -- )
|
|
linearization-order [ block. ] each ;
|
|
|
|
: stack-frame. ( cfg -- )
|
|
stack-frame>> "=== stack frame: %u\n" printf ;
|
|
|
|
: cfg. ( cfg -- )
|
|
dup linearization-order number-blocks [
|
|
[ cfg-header. ] [ blocks. ] [ stack-frame. ] tri
|
|
] with-scope ;
|
|
|
|
: cfgs. ( cfgs -- )
|
|
[ nl ] [ cfg. ] interleave ;
|
|
|
|
: ssa. ( quot/word -- ) test-ssa cfgs. ;
|
|
: flat. ( quot/word -- ) test-flat cfgs. ;
|
|
: regs. ( quot/word -- ) test-regs cfgs. ;
|