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 fry 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 : compiler-test ( name -- )
  26     "resource:basis/compiler/tests/" ".factor" surround run-test-file ;
  27
  28 : init-cfg-test ( -- )
  29     reset-vreg-counter begin-stack-analysis
  30     <basic-block> dup basic-block set begin-local-analysis
  31     H{ } clone representations set
  32     H{ } clone replaces set ;
  33
  34 : cfg-unit-test ( result quot -- )
  35     '[ init-cfg-test @ ] unit-test ; inline
  36
  37 : edge ( from to -- )
  38     [ get ] bi@ 1vector >>successors drop ;
  39
  40 : edges ( from tos -- )
  41     [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
  42
  43 : test-diamond ( -- )
  44     0 1 edge
  45     1 { 2 3 } edges
  46     2 4 edge
  47     3 4 edge ;
  48
  49 : resolve-phis ( bb -- )
  50     [
  51         [ [ [ get ] dip ] assoc-map ] change-inputs drop
  52     ] each-phi ;
  53
  54 : test-bb ( insns n -- )
  55     [ insns>block dup ] keep set resolve-phis ;
  56
  57 : fake-representations ( cfg -- )
  58     post-order [
  59         instructions>> [
  60             [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
  61             [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
  62             bi append
  63         ] map concat
  64     ] map concat >hashtable representations set ;
  65
  66 : count-insns ( quot insn-check -- ? )
  67     [ test-regs [ cfg>insns ] map concat ] dip count ; inline
  68
  69 : contains-insn? ( quot insn-check -- ? )
  70     count-insns 0 > ; inline
  71
  72 : make-edges ( block-map edgelist -- )
  73     [ [ of ] with map first2 connect-bbs ] with each ;
  74
  75 : final-info ( quot -- seq )
  76     build-tree
  77     analyze-recursive
  78     normalize
  79     propagate
  80     compute-def-use
  81     dup check-nodes
  82     last node-input-infos ;
  83
  84 : final-classes ( quot -- seq )
  85     final-info [ class>> ] map ;
  86
  87 : final-literals ( quot -- seq )
  88     final-info [ literal>> ] map ;