basis/compiler/cfg/debugger/debugger.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel words sequences quotations namespaces io vectors
   4 arrays hashtables classes.tuple accessors prettyprint
   5 prettyprint.config assocs prettyprint.backend prettyprint.custom
   6 prettyprint.sections parser compiler.tree.builder
   7 compiler.tree.optimizer cpu.architecture compiler.cfg.builder
   8 compiler.cfg.linearization compiler.cfg.registers
   9 compiler.cfg.stack-frame compiler.cfg.linear-scan
  10 compiler.cfg.two-operand compiler.cfg.optimizer
  11 compiler.cfg.instructions compiler.cfg.utilities
  12 compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
  13 compiler.cfg.representations.preferred compiler.cfg ;
  14 IN: compiler.cfg.debugger
  15
  16 GENERIC: test-cfg ( quot -- cfgs )
  17
  18 M: callable test-cfg
  19     0 vreg-counter set-global
  20     build-tree optimize-tree gensym build-cfg ;
  21
  22 M: word test-cfg
  23     0 vreg-counter set-global
  24     [ build-tree optimize-tree ] keep build-cfg ;
  25
  26 : test-mr ( quot -- mrs )
  27     test-cfg [
  28         [
  29             optimize-cfg
  30             build-mr
  31         ] with-cfg
  32     ] map ;
  33
  34 : insn. ( insn -- )
  35     tuple>array but-last [ pprint bl ] each nl ;
  36
  37 : mr. ( mrs -- )
  38     [
  39         "=== word: " write
  40         dup word>> pprint
  41         ", label: " write
  42         dup label>> pprint nl nl
  43         instructions>> [ insn. ] each
  44         nl
  45     ] each ;
  46
  47 ! Prettyprinting
  48 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
  49
  50 M: ds-loc pprint* \ D pprint-loc ;
  51
  52 M: rs-loc pprint* \ R pprint-loc ;
  53
  54 : resolve-phis ( bb -- )
  55     [
  56         [ [ [ get ] dip ] assoc-map ] change-inputs drop
  57     ] each-phi ;
  58
  59 : test-bb ( insns n -- )
  60     [ <basic-block> swap >>number swap >>instructions dup ] keep set
  61     resolve-phis ;
  62
  63 : edge ( from to -- )
  64     [ get ] bi@ 1vector >>successors drop ;
  65
  66 : edges ( from tos -- )
  67     [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
  68
  69 : test-diamond ( -- )
  70     0 1 edge
  71     1 { 2 3 } edges
  72     2 4 edge
  73     3 4 edge ;
  74
  75 : fake-representations ( cfg -- )
  76     post-order [
  77         instructions>> [
  78             [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
  79             [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
  80             bi [ suffix ] when*
  81         ] map concat
  82     ] map concat >hashtable representations set ;