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 compiler.cfg.gc-checks
   5 compiler.cfg.instructions compiler.cfg.linearization
   6 compiler.cfg.optimizer compiler.cfg.registers
   7 compiler.cfg.representations compiler.cfg.save-contexts
   8 compiler.cfg.utilities compiler.tree.builder compiler.tree.optimizer
   9 formatting fry io kernel math namespaces prettyprint quotations
  10 sequences strings words ;
  11 IN: compiler.cfg.debugger
  12
  13 GENERIC: test-builder ( quot -- cfgs )
  14
  15 : build-optimized-tree ( callable/word -- tree )
  16     reset-vreg-counter
  17     build-tree optimize-tree ;
  18
  19 M: callable test-builder
  20     build-optimized-tree gensym build-cfg ;
  21
  22 M: word test-builder
  23     [ build-optimized-tree ] keep build-cfg ;
  24
  25 : run-passes ( cfgs passes -- cfgs' )
  26     '[ dup cfg set dup _ apply-passes ] map ; inline
  27
  28 : test-ssa ( quot -- cfgs )
  29     test-builder { optimize-cfg } run-passes ;
  30
  31 : test-flat ( quot -- cfgs )
  32     test-builder {
  33         optimize-cfg
  34         select-representations
  35         insert-gc-checks
  36         insert-save-contexts
  37     } run-passes ;
  38
  39 : test-regs ( quot -- cfgs )
  40     test-builder { optimize-cfg finalize-cfg } run-passes ;
  41
  42 GENERIC: insn. ( insn -- )
  43
  44 M: ##phi insn.
  45     clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
  46     call-next-method ;
  47
  48 ! XXX: pprint on a string prints the double quotes.
  49 ! This will cause graphviz to choke, so print without quotes.
  50 : insn-number. ( n -- )
  51     dup integer? [ "%4d " printf ] [ drop "     " printf ] if ;
  52
  53 M: insn insn. ( insn -- )
  54     tuple>array unclip-last insn-number. [
  55         dup string? [ ] [ unparse ] if
  56     ] map " " join write nl ;
  57
  58 : block-header. ( bb -- )
  59     [ number>> ] [ kill-block?>> "(k)" "" ? ] bi
  60     "=== Basic block #%d %s\n\n" printf ;
  61
  62 : instructions. ( bb -- )
  63     instructions>> [ insn. ] each nl ;
  64
  65 : successors. ( bb -- )
  66     successors>> [
  67         [ number>> unparse ] map ", " join
  68         "Successors: %s\n\n" printf
  69     ] unless-empty ;
  70
  71 : block. ( bb -- )
  72     [ block-header. ] [ instructions. ] [ successors. ] tri ;
  73
  74 : cfg-header. ( cfg -- )
  75     [ word>> ] [ label>> ] bi "=== word: %u, label: %u\n\n" printf ;
  76
  77 : blocks. ( cfg -- )
  78     linearization-order [ block. ] each ;
  79
  80 : stack-frame. ( cfg -- )
  81     stack-frame>> "=== stack frame: %u\n" printf ;
  82
  83 : cfg. ( cfg -- )
  84     dup linearization-order number-blocks [
  85         [ cfg-header. ] [ blocks. ] [ stack-frame. ] tri
  86     ] with-scope ;
  87
  88 : cfgs. ( cfgs -- )
  89     [ nl ] [ cfg. ] interleave ;
  90
  91 : ssa. ( quot/word -- ) test-ssa cfgs. ;
  92 : flat. ( quot/word -- ) test-flat cfgs. ;
  93 : regs. ( quot/word -- ) test-regs cfgs. ;