1f83c72579522ff57adbc8b17720175ac7b6492b
[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 import System.Exit
8
9 import qualified Ast as A
10 import qualified Ir2ast as Ia
11 import Ast2ir
12 import ConstProp
13 import Eval (evalProg, ErrorM)
14 import IR
15 import Live
16 import Parse (parseCode)
17 import Simplify
18 parse :: String -> String -> ErrorM (M [(IdLabelMap, Proc)])
19 parse file text =
20 case parseCode file text of
21 Left err -> throwError $ show err
22 Right ps -> return $ mapM astToIR ps
23
24 parseTest :: String -> IO ()
25 parseTest file =
26 do text <- readFile file
27 case parse file text of
28 Left err -> putStrLn err
29 Right p -> mapM (putStrLn . showProc . snd) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return ()
30
31 evalTest' :: String -> String -> ErrorM String
32 evalTest' file text =
33 do procs <- parse file text
34 (_, vs) <- (testProg . snd . unzip) (runSimpleUniqueMonad $ runWithFuel 0 procs)
35 return $ "returning: " ++ show vs
36 where
37 testProg procs@(Proc {name, args} : _) = evalProg procs vsupply name (toV args)
38 testProg _ = throwError "No procedures in test program"
39 toV args = [I n | (n, _) <- zip [3..] args]
40 vsupply = [I x | x <- [5..]]
41
42 evalTest :: String -> IO ()
43 evalTest file =
44 do text <- readFile file
45 case evalTest' file text of
46 Left err -> putStrLn err
47 Right s -> putStrLn s
48
49 optTest' :: M [Proc] -> ErrorM (M [Proc])
50 optTest' procs =
51 return $ procs >>= mapM optProc
52 where
53 optProc proc@(Proc {entry, body, args}) =
54 do { (body', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body
55 (mapSingleton entry (initFact args))
56 ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty
57 ; return $ proc { body = body'' } }
58 -- With debugging info:
59 -- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
60 -- , fp_rewrite = constProp `thenFwdRw` simplify }
61 fwd = constPropPass
62 bwd = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness
63 , bp_rewrite = deadAsstElim }
64
65 constPropPass :: FuelMonad m => FwdPass m Insn ConstFact
66 -- @ start cprop.tex
67
68 ----------------------------------------
69 -- Defining the forward dataflow pass
70 constPropPass = FwdPass
71 { fp_lattice = constLattice
72 , fp_transfer = varHasLit
73 , fp_rewrite = constProp `thenFwdRw` simplify }
74 -- @ end cprop.tex
75
76 toAst :: [(IdLabelMap, Proc)] -> [A.Proc]
77 toAst l = fmap (uncurry Ia.irToAst) l
78
79 compareAst :: [A.Proc] -> [A.Proc] -> IO ()
80 compareAst [] [] = return ()
81 compareAst (r:results) (e:expected) =
82 if r == e
83 then compareAst results expected
84 else
85 do { putStrLn "expecting"
86 ; putStrLn $ A.showProc e
87 ; putStrLn "resulting"
88 ; putStrLn $ A.showProc r
89 ; putStrLn "the result does not match the expected, abort the test!!!!"
90 ; exitFailure
91 }
92 compareAst results expected = do { putStrLn "expecting"
93 ; mapM_ (putStrLn . A.showProc) expected
94 ; putStrLn "resulting"
95 ; mapM_ (putStrLn . A.showProc) results
96 ; putStrLn "the result does not match the expected, abort the test!!!!"
97 ; exitFailure
98 }
99
100
101
102 optTest :: String -> String -> IO ()
103 optTest file expectedFile =
104 do text <- readFile file
105 expectedText <- readFile expectedFile
106 case (parse file text, parse expectedFile expectedText) of
107 (Left err, _) -> putStrLn err
108 (_, Left err) -> putStrLn err
109 (Right lps, Right exps) ->
110 case optTest' (liftM (snd . unzip) lps) of
111 Left err -> putStrLn err
112 Right p -> do { let opted = runSimpleUniqueMonad $ runWithFuel fuel p
113 lbmaps = runSimpleUniqueMonad $ runWithFuel fuel (liftM (fst . unzip) lps)
114 expected = runSimpleUniqueMonad $ runWithFuel fuel exps
115 ; compareAst (toAst (zip lbmaps opted)) (toAst expected)
116 }
117 where
118 fuel = 9999
119
120
121
122 {-- Properties to test:
123
124 1. Is the fixpoint complete (maps all blocks to facts)?
125 2. Is the computed fixpoint actually a fixpoint?
126 3. Random test generation.
127
128 --}