Constant-propagation figure is now extracted automatically from John's code; some...
[packages/hoopl.git] / testing / Test.hs
1 {-# OPTIONS_GHC -Wall #-}
2 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
3 module Test (parseTest, evalTest, optTest) where
4
5 import Compiler.Hoopl
6 import Control.Monad.Error
7
8 import Ast2ir
9 import ConstProp
10 import Eval (evalProg, ErrorM)
11 import IR
12 import Live
13 import Parse (parseCode)
14 import Simplify
15
16 parse :: String -> String -> ErrorM (M [Proc])
17 parse file text =
18 case parseCode file text of
19 Left err -> throwError $ show err
20 Right ps -> return $ mapM astToIR ps
21
22 parseTest :: String -> IO ()
23 parseTest file =
24 do text <- readFile file
25 case parse file text of
26 Left err -> putStrLn err
27 Right p -> mapM (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return ()
28
29 evalTest' :: String -> String -> ErrorM String
30 evalTest' file text =
31 do procs <- parse file text
32 (_, vs) <- testProg (runSimpleUniqueMonad $ runWithFuel 0 procs)
33 return $ "returning: " ++ show vs
34 where
35 testProg procs@(Proc {name, args} : _) = evalProg procs vsupply name (toV args)
36 testProg _ = throwError "No procedures in test program"
37 toV args = [I n | (n, _) <- zip [3..] args]
38 vsupply = [I x | x <- [5..]]
39
40 evalTest :: String -> IO ()
41 evalTest file =
42 do text <- readFile file
43 case evalTest' file text of
44 Left err -> putStrLn err
45 Right s -> putStrLn s
46
47 optTest' :: String -> String -> ErrorM (M [Proc])
48 optTest' file text =
49 do procs <- parse file text
50 return $ procs >>= mapM optProc
51 where
52 optProc proc@(Proc {entry, body, args}) =
53 do { (body', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body (mkFactBase [(entry, initFact args)])
54 ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' (mkFactBase [])
55 ; return $ proc { body = body'' } }
56 -- With debugging info:
57 -- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
58 -- , fp_rewrite = constProp `thenFwdRw` simplify }
59 fwd = constPropPass
60 bwd = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness
61 , bp_rewrite = deadAsstElim }
62
63 constPropPass :: Monad m => FwdPass m Insn ConstFact
64 -- @ start cprop.tex
65
66 ----------------------------------------
67 -- Defining the forward dataflow pass
68 constPropPass = FwdPass
69 { fp_lattice = constLattice
70 , fp_transfer = varHasLit
71 , fp_rewrite = constProp `thenFwdRw` simplify }
72 -- @ end cprop.tex
73
74 optTest :: String -> IO ()
75 optTest file =
76 do text <- readFile file
77 case optTest' file text of
78 Left err -> putStrLn err
79 Right p -> mapM_ (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel fuel p)
80 where
81 fuel = 99999
82
83
84
85 {-- Properties to test:
86
87 1. Is the fixpoint complete (maps all blocks to facts)?
88 2. Is the computed fixpoint actually a fixpoint?
89 3. Random test generation.
90
91 --}