basis/compiler/cfg/debugger/debugger.factor

   1 ! Copyright (C) 2008, 2011 Slava Pestov.
   2 ! See http://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
  13
  14 GENERIC: test-builder ( quot -- cfgs )
  15
  16 : build-optimized-tree ( callable/word -- tree )
  17     reset-vreg-counter
  18     build-tree optimize-tree ;
  19
  20 M: callable test-builder
  21     build-optimized-tree gensym build-cfg ;
  22
  23 M: word test-builder
  24     [ build-optimized-tree ] keep build-cfg ;
  25
  26 : run-passes ( cfgs passes -- cfgs' )
  27     '[ dup cfg set dup _ apply-passes ] map ; inline
  28
  29 : test-ssa ( quot -- cfgs )
  30     test-builder { optimize-cfg } run-passes ;
  31
  32 : test-flat ( quot -- cfgs )
  33     test-builder {
  34         optimize-cfg
  35         select-representations
  36         insert-gc-checks
  37         insert-save-contexts
  38     } run-passes ;
  39
  40 : test-regs ( quot -- cfgs )
  41     test-builder { optimize-cfg finalize-cfg } run-passes ;
  42
  43 GENERIC: insn. ( insn -- )
  44
  45 M: ##phi insn.
  46     clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
  47     call-next-method ;
  48
  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 ;
  53
  54 M: insn insn. ( insn -- )
  55     tuple>array unclip-last insn-number. [
  56         dup string? [ ] [ unparse ] if
  57     ] map unwords write nl ;
  58
  59 : block-header. ( bb -- )
  60     [ number>> ] [ kill-block?>> "(k)" "" ? ] bi
  61     "=== Basic block #%d %s\n\n" printf ;
  62
  63 : instructions. ( bb -- )
  64     instructions>> [ insn. ] each nl ;
  65
  66 : successors. ( bb -- )
  67     successors>> [
  68         [ number>> unparse ] map ", " join
  69         "Successors: %s\n\n" printf
  70     ] unless-empty ;
  71
  72 : block. ( bb -- )
  73     [ block-header. ] [ instructions. ] [ successors. ] tri ;
  74
  75 : cfg-header. ( cfg -- )
  76     [ word>> ] [ label>> ] bi "=== word: %u, label: %u\n\n" printf ;
  77
  78 : blocks. ( cfg -- )
  79     linearization-order [ block. ] each ;
  80
  81 : stack-frame. ( cfg -- )
  82     stack-frame>> "=== stack frame: %u\n" printf ;
  83
  84 : cfg. ( cfg -- )
  85     dup linearization-order number-blocks [
  86         [ cfg-header. ] [ blocks. ] [ stack-frame. ] tri
  87     ] with-scope ;
  88
  89 : cfgs. ( cfgs -- )
  90     [ nl ] [ cfg. ] interleave ;
  91
  92 : ssa. ( quot/word -- ) test-ssa cfgs. ;
  93 : flat. ( quot/word -- ) test-flat cfgs. ;
  94 : regs. ( quot/word -- ) test-regs cfgs. ;