basis/compiler/test/test.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs compiler.cfg compiler.cfg.debugger
   4 compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.registers
   5 compiler.cfg.representations.preferred compiler.cfg.rpo
   6 compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
   7 compiler.tree.builder compiler.tree.checker compiler.tree.def-use
   8 compiler.tree.normalization compiler.tree.propagation
   9 compiler.tree.propagation.info compiler.tree.recursive compiler.units
  10 hashtables kernel math namespaces sequences stack-checker
  11 tools.test vectors vocabs words ;
  12 IN: compiler.test
  13
  14 : decompile ( word -- )
  15     dup def>> 2array 1array t t modify-code-heap ;
  16
  17 : recompile-all ( -- )
  18     all-words compile ;
  19
  20 : compile-call ( quot -- )
  21     [ dup infer define-temp ] with-compilation-unit execute ;
  22
  23 << \ compile-call t "no-compile" set-word-prop >>
  24
  25 : init-cfg-test ( -- )
  26     reset-vreg-counter begin-stack-analysis
  27     <basic-block> dup basic-block set begin-local-analysis
  28     H{ } clone representations set
  29     H{ } clone replaces set ;
  30
  31 : cfg-unit-test ( result quot -- )
  32     '[ init-cfg-test @ ] unit-test ; inline
  33
  34 : edge ( from to -- )
  35     [ get ] bi@ 1vector >>successors drop ;
  36
  37 : edges ( from tos -- )
  38     [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
  39
  40 : test-diamond ( -- )
  41     0 1 edge
  42     1 { 2 3 } edges
  43     2 4 edge
  44     3 4 edge ;
  45
  46 : resolve-phis ( bb -- )
  47     [
  48         [ [ [ get ] dip ] assoc-map ] change-inputs drop
  49     ] each-phi ;
  50
  51 : test-bb ( insns n -- )
  52     [ insns>block dup ] keep set resolve-phis ;
  53
  54 : fake-representations ( cfg -- )
  55     post-order [
  56         instructions>> [
  57             [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
  58             [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
  59             bi append
  60         ] map concat
  61     ] map concat >hashtable representations set ;
  62
  63 : count-insns ( quot insn-check -- ? )
  64     [ test-regs [ cfg>insns ] map concat ] dip count ; inline
  65
  66 : contains-insn? ( quot insn-check -- ? )
  67     count-insns 0 > ; inline
  68
  69 : make-edges ( block-map edgelist -- )
  70     [ [ of ] with map first2 connect-bbs ] with each ;
  71
  72 : final-info ( quot -- seq )
  73     build-tree
  74     analyze-recursive
  75     normalize
  76     propagate
  77     compute-def-use
  78     dup check-nodes
  79     last node-input-infos ;
  80
  81 : final-classes ( quot -- seq )
  82     final-info [ class>> ] map ;
  83
  84 : final-literals ( quot -- seq )
  85     final-info [ literal>> ] map ;