factor: trim using lists

[factor.git] / basis / compiler / test / test.factor

diff --git a/basis/compiler/test/test.factor b/basis/compiler/test/test.factor
index 66e3f39f65b5b9f0b0b37daa57f65877dbbb1a28..0a7e9f4823a5c9b147ada6561c7d27d7dd81a47f 100644 (file)
--- a/basis/compiler/test/test.factor
+++ b/basis/compiler/test/test.factor
@@ -1,11 +1,18 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays compiler.units kernel stack-checker
-sequences vocabs words tools.test tools.test.private ;
+USING: accessors arrays assocs compiler.cfg compiler.cfg.debugger
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.registers
+compiler.cfg.representations.preferred compiler.cfg.rpo
+compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.utilities
+compiler.tree.builder compiler.tree.checker compiler.tree.def-use
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.propagation.info compiler.tree.recursive compiler.units
+hashtables kernel math namespaces sequences stack-checker
+tools.test vectors vocabs words ;
 IN: compiler.test
 
 : decompile ( word -- )
-    dup def>> 2array 1array modify-code-heap ;
+    dup def>> 2array 1array t t modify-code-heap ;
 
 : recompile-all ( -- )
     all-words compile ;
@@ -13,7 +20,66 @@ IN: compiler.test
 : compile-call ( quot -- )
     [ dup infer define-temp ] with-compilation-unit execute ;
 
-\ compile-call t "no-compile" set-word-prop
+<< \ compile-call t "no-compile" set-word-prop >>
 
-: compiler-test ( name -- )
-    "resource:basis/compiler/tests/" ".factor" surround run-test-file ;
+: init-cfg-test ( -- )
+    reset-vreg-counter begin-stack-analysis
+    <basic-block> dup basic-block set begin-local-analysis
+    H{ } clone representations set
+    H{ } clone replaces set ;
+
+: cfg-unit-test ( result quot -- )
+    '[ init-cfg-test @ ] unit-test ; inline
+
+: edge ( from to -- )
+    [ get ] bi@ 1vector >>successors drop ;
+
+: edges ( from tos -- )
+    [ get ] [ [ get ] V{ } map-as ] bi* >>successors drop ;
+
+: test-diamond ( -- )
+    0 1 edge
+    1 { 2 3 } edges
+    2 4 edge
+    3 4 edge ;
+
+: resolve-phis ( bb -- )
+    [
+        [ [ [ get ] dip ] assoc-map ] change-inputs drop
+    ] each-phi ;
+
+: test-bb ( insns n -- )
+    [ insns>block dup ] keep set resolve-phis ;
+
+: fake-representations ( cfg -- )
+    post-order [
+        instructions>> [
+            [ [ temp-vregs ] [ temp-vreg-reps ] bi zip ]
+            [ [ defs-vregs ] [ defs-vreg-reps ] bi zip ]
+            bi append
+        ] map concat
+    ] map concat >hashtable representations set ;
+
+: count-insns ( quot insn-check -- ? )
+    [ test-regs [ cfg>insns ] map concat ] dip count ; inline
+
+: contains-insn? ( quot insn-check -- ? )
+    count-insns 0 > ; inline
+
+: make-edges ( block-map edgelist -- )
+    [ [ of ] with map first2 connect-bbs ] with each ;
+
+: final-info ( quot -- seq )
+    build-tree
+    analyze-recursive
+    normalize
+    propagate
+    compute-def-use
+    dup check-nodes
+    last node-input-infos ;
+
+: final-classes ( quot -- seq )
+    final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+    final-info [ literal>> ] map ;