1 ! Copyright (C) 2008, 2011 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs classes.tuple compiler.cfg
4 compiler.cfg.builder compiler.cfg.finalization
5 compiler.cfg.gc-checks compiler.cfg.instructions
6 compiler.cfg.linearization compiler.cfg.optimizer
7 compiler.cfg.registers compiler.cfg.representations
8 compiler.cfg.save-contexts compiler.cfg.utilities
9 compiler.tree.builder compiler.tree.optimizer formatting io
10 kernel math namespaces prettyprint quotations sequences
11 splitting strings words ;
12 IN: compiler.cfg.debugger
14 GENERIC: test-builder ( quot -- cfgs )
16 : build-optimized-tree ( callable/word -- tree )
18 build-tree optimize-tree ;
20 M: callable test-builder
21 build-optimized-tree gensym build-cfg ;
24 [ build-optimized-tree ] keep build-cfg ;
26 : run-passes ( cfgs passes -- cfgs' )
27 '[ dup cfg set dup _ apply-passes ] map ; inline
29 : test-ssa ( quot -- cfgs )
30 test-builder { optimize-cfg } run-passes ;
32 : test-flat ( quot -- cfgs )
35 select-representations
40 : test-regs ( quot -- cfgs )
41 test-builder { optimize-cfg finalize-cfg } run-passes ;
43 GENERIC: insn. ( insn -- )
46 clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
49 ! XXX: pprint on a string prints the double quotes.
50 ! This will cause graphviz to choke, so print without quotes.
51 : insn-number. ( n -- )
52 dup integer? [ "%4d " printf ] [ drop " " printf ] if ;
54 M: insn insn. ( insn -- )
55 tuple>array unclip-last insn-number. [
56 dup string? [ ] [ unparse ] if
57 ] map join-words write nl ;
59 : block-header. ( bb -- )
60 [ number>> ] [ kill-block?>> "(k)" "" ? ] bi
61 "=== Basic block #%d %s\n\n" printf ;
63 : instructions. ( bb -- )
64 instructions>> [ insn. ] each nl ;
66 : successors. ( bb -- )
68 [ number>> unparse ] map ", " join
69 "Successors: %s\n\n" printf
73 [ block-header. ] [ instructions. ] [ successors. ] tri ;
75 : cfg-header. ( cfg -- )
76 [ word>> ] [ label>> ] bi "=== word: %u, label: %u\n\n" printf ;
79 linearization-order [ block. ] each ;
81 : stack-frame. ( cfg -- )
82 stack-frame>> "=== stack frame: %u\n" printf ;
85 dup linearization-order number-blocks [
86 [ cfg-header. ] [ blocks. ] [ stack-frame. ] tri
90 [ nl ] [ cfg. ] interleave ;
92 : ssa. ( quot/word -- ) test-ssa cfgs. ;
93 : flat. ( quot/word -- ) test-flat cfgs. ;
94 : regs. ( quot/word -- ) test-regs cfgs. ;