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.optimizer compiler.cfg.instructions
  11 compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
  12 compiler.cfg.mr compiler.cfg.representations.preferred
  13 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 : test-mr. ( quot -- )
  48     test-mr mr. ; inline
  49
  50 ! Prettyprinting
  51 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
  52
  53 M: ds-loc pprint* \ D pprint-loc ;
  54
  55 M: rs-loc pprint* \ R pprint-loc ;
  56
  57 : resolve-phis ( bb -- )
  58     [
  59         [ [ [ get ] dip ] assoc-map ] change-inputs drop
  60     ] each-phi ;
  61
  62 : test-bb ( insns n -- )
  63     [ <basic-block> swap >>number swap >>instructions dup ] keep set
  64     resolve-phis ;
  65
  66 : edge ( from to -- )
  67     [ get ] bi@ 1vector >>successors drop ;
  68
  69 : edges ( from tos -- )
  70     [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
  71
  72 : test-diamond ( -- )
  73     0 1 edge
  74     1 { 2 3 } edges
  75     2 4 edge
  76     3 4 edge ;
  77
  78 : fake-representations ( cfg -- )
  79     post-order [
  80         instructions>> [
  81             [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
  82             [ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
  83             bi [ suffix ] when*
  84         ] map concat
  85     ] map concat >hashtable representations set ;