ea443f3b0f67fecd50a1ec531667aedc1ab5933e
[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
54 (mapSingleton entry (initFact args))
55 ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty
56 ; return $ proc { body = body'' } }
57 -- With debugging info:
58 -- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
59 -- , fp_rewrite = constProp `thenFwdRw` simplify }
60 fwd = constPropPass
61 bwd = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness
62 , bp_rewrite = deadAsstElim }
63
64 constPropPass :: FuelMonad m => FwdPass m Insn ConstFact
65 -- @ start cprop.tex
66
67 ----------------------------------------
68 -- Defining the forward dataflow pass
69 constPropPass = FwdPass
70 { fp_lattice = constLattice
71 , fp_transfer = varHasLit
72 , fp_rewrite = constProp `thenFwdRw` simplify }
73 -- @ end cprop.tex
74
75 optTest :: String -> IO ()
76 optTest file =
77 do text <- readFile file
78 case optTest' file text of
79 Left err -> putStrLn err
80 Right p -> mapM_ (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel fuel p)
81 where
82 fuel = 99999
83
84
85
86 {-- Properties to test:
87
88 1. Is the fixpoint complete (maps all blocks to facts)?
89 2. Is the computed fixpoint actually a fixpoint?
90 3. Random test generation.
91
92 --}