Commit 9c07a4b7 authored by Michal Terepeta's avatar Michal Terepeta

Remove trailing whitespace in testing/

parent d9e9cee0
......@@ -35,19 +35,19 @@ type Lbl = String
showProc :: Proc -> String
showProc (Proc { name = n, args = as, body = blks})
showProc (Proc { name = n, args = as, body = blks})
= n ++ tuple as ++ graph
where
graph = foldl (\p b -> p ++ "\n" ++ show b) (" {") blks ++ "\n}\n"
instance Show Block where
show (Block f m l) = (foldl (\p e -> p ++ "\n" ++ show e) (f++":") m) ++ "\n" ++ show l
show (Block f m l) = (foldl (\p e -> p ++ "\n" ++ show e) (f++":") m) ++ "\n" ++ show l
instance Show Insn where
show (Assign v e) = ind $ v ++ " = " ++ show e
show (Store addr e) = ind $ "m[" ++ show addr ++ "] = " ++ show e
instance Show Control where
instance Show Control where
show (Branch lbl) = ind $ "goto " ++ lbl
show (Cond e t f) =
ind $ "if " ++ show e ++ " then goto " ++ t ++ " else goto " ++ f
......
......@@ -13,7 +13,7 @@ import qualified Data.Map as M
import qualified Control.Applicative as AP (Applicative(..))
#endif
#else
import qualified Control.Applicative as AP (Applicative(..))
import qualified Control.Applicative as AP (Applicative(..))
#endif
import qualified Ast as A
......@@ -37,9 +37,9 @@ astToIR (A.Proc {A.name = n, A.args = as, A.body = b}) = run $
do entry <- getEntry b
body <- toBody b
return $ I.Proc { I.name = n, I.args = as, I.body = body, I.entry = entry }
getEntry :: [A.Block] -> LabelMapM Label
getEntry [] = error "Parsed procedures should not be empty"
getEntry (b : _) = labelFor $ A.first b
......@@ -83,15 +83,15 @@ instance Monad LabelMapM where
LabelMapM f1 >>= k = LabelMapM (\m -> do (m', x) <- f1 m
let (LabelMapM f2) = k x
f2 m')
instance Functor LabelMapM where
instance Functor LabelMapM where
fmap = liftM
instance AP.Applicative LabelMapM where
instance AP.Applicative LabelMapM where
pure = return
(<*>) = ap
labelFor l = LabelMapM f
where f m = case M.lookup l m of
Just l' -> return (m, l')
......
......@@ -24,7 +24,7 @@ constLattice = DataflowLattice
, fact_bot = Map.empty
, fact_join = joinMaps (extendJoinDomain constFactAdd) }
where
constFactAdd _ (OldFact old) (NewFact new)
constFactAdd _ (OldFact old) (NewFact new)
= if new == old then (NoChange, PElem new)
else (SomeChange, Top)
......@@ -49,7 +49,7 @@ varHasLit = mkFTransfer ft
ft (Assign x _) f = Map.insert x Top f
ft (Store _ _) f = f
ft (Branch l) f = mapSingleton l f
ft (Cond (Var x) tl fl) f
ft (Cond (Var x) tl fl) f
= mkFactBase constLattice
[(tl, Map.insert x (PElem (Bool True)) f),
(fl, Map.insert x (PElem (Bool False)) f)]
......@@ -74,7 +74,7 @@ constProp = mkFRewrite cp
mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x)
mapVN = mapEN . mapEE . mapVE
lookup :: ConstFact -> Var -> Maybe Expr
lookup f x = case Map.lookup x f of
Just (PElem v) -> Just $ Lit v
......
......@@ -28,7 +28,7 @@ evalProc' (Proc {name=_, args, body, entry}) actuals =
-- Responsible for allocating and deallocating its own stack frame.
evalBody :: EvalTarget v => VarEnv v -> Graph Insn C C -> Label -> EvalM v [v]
evalBody vars graph entry = inNewFrame vars graph $ get_block entry >>= evalB
evalBody vars graph entry = inNewFrame vars graph $ get_block entry >>= evalB
evalB :: forall v . EvalTarget v => Block Insn C C -> EvalM v [v]
evalB b = foldBlockNodesF3 (lift evalF, lift evalM, lift evalL) b $ return ()
......@@ -111,7 +111,7 @@ instance EvalTarget Value where
return $ up $ op v_x v_y
fromI (I x) = return x
fromI (B _) = throwError "fromI: got a B"
fromB (I _) = throwError "fromB: got an I"
fromB (B x) = return x
......
......@@ -56,7 +56,7 @@ type PEnv = M.Map String Proc
type G = Graph Insn C C
runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x)
runProg procs vs (EvalM f) =
runProg procs vs (EvalM f) =
case f init_state of
Left (_, e) -> throwError e
Right x -> return x
......@@ -64,7 +64,7 @@ runProg procs vs (EvalM f) =
init_state = State { frames = [], heap = M.empty, events = [],
vsupply = vs, procs = procMap }
procMap = M.fromList $ zip (map name procs) procs
get_state :: EvalM v (State v)
get_state = EvalM f
where f state = return (state, state)
......@@ -137,7 +137,7 @@ inNewFrame vars graph runFrame =
x <- runFrame
popFrame
return x
mlookup :: Ord k => String -> k -> M.Map k v -> EvalM v' v
mlookup blame k m =
case M.lookup k m of
......
......@@ -8,11 +8,11 @@ data Expr = Lit Lit
| Var Var
| Load Expr
| Binop BinOp Expr Expr deriving (Eq)
data BinOp = Add | Sub | Mul | Div | Eq | Ne | Lt | Gt | Lte | Gte deriving Eq
data Lit = Bool Bool | Int Integer deriving Eq
type Var = String
type Var = String
--------------------------------------------------------------------------------
--- Prettyprinting
......
......@@ -13,8 +13,8 @@ import Control.Monad.Reader
type Rm = Reader (M.Map Label A.Lbl)
invertMap :: (Ord k, Ord v) => M.Map k v -> M.Map v k
invertMap m = foldl (\p (k,v) ->
if M.member v p
invertMap m = foldl (\p (k,v) ->
if M.member v p
then error $ "irrefutable error in invertMap, the values are not unique"
else M.insert v k p
) M.empty (M.toList m)
......@@ -28,7 +28,7 @@ strLabelFor l = do { mp <- ask
}
irToAst :: M.Map String Label -> I.Proc -> A.Proc
irToAst mp (I.Proc {I.name = n, I.args = as, I.body = graph, I.entry = entry }) =
irToAst mp (I.Proc {I.name = n, I.args = as, I.body = graph, I.entry = entry }) =
runReader (do { body <- fromGraph entry graph
; return $ A.Proc { A.name = n, A.args = as, A.body = body }
}) (invertMap mp)
......@@ -39,36 +39,36 @@ fromGraph entry g = let entryNode = gUnitOC (BlockOC BNil (I.Branch entry))
in foldM (\p blk -> do { ablk <- fromBlock blk ()
; return (ablk:p)
}) [] blks
type instance IndexedCO C () (Rm (A.Lbl, [A.Insn])) = ()
type instance IndexedCO C (Rm A.Block) (Rm (A.Lbl, [A.Insn])) = Rm A.Block
fromBlock :: Block I.Insn C C -> () -> Rm A.Block
fromBlock blk = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) blk
fromBlock blk = foldBlockNodesF3 (fromIrInstCO, fromIrInstOO, fromIrInstOC) blk
fromIrInstCO :: I.Insn C O -> () -> Rm (A.Lbl, [A.Insn])
fromIrInstCO inst _ = case inst of
I.Label l -> strLabelFor l >>= \x -> return (x, [])
fromIrInstOO :: I.Insn O O -> Rm (A.Lbl, [A.Insn]) -> Rm (A.Lbl, [A.Insn])
fromIrInstOO inst p = case inst of
I.Assign v e -> do { (sl, insts) <- p
; return (sl, (A.Assign v e):insts)
}
I.Store a e -> do { (sl, insts) <- p
I.Store a e -> do { (sl, insts) <- p
; return (sl, (A.Store a e):insts)
}
fromIrInstOC :: I.Insn e x -> Rm (A.Lbl, [A.Insn]) -> Rm A.Block
fromIrInstOC inst p = case inst of
I.Branch tl -> do { (l, insts) <- p
I.Branch tl -> do { (l, insts) <- p
; stl <- strLabelFor tl
; return $ A.Block {A.first = l, A.mids = reverse insts
; return $ A.Block {A.first = l, A.mids = reverse insts
, A.last = A.Branch stl}
}
I.Cond e tl fl -> do { (l, insts)<- p
......
......@@ -35,12 +35,12 @@ liveness = mkBTransfer live
fact :: FactBase (S.Set Var) -> Label -> Live
fact f l = fromMaybe S.empty $ lookupFact l f
addUses :: S.Set Var -> Insn e x -> Live
addUses = fold_EN (fold_EE addVar)
addVar s (Var v) = S.insert v s
addVar s _ = s
deadAsstElim :: forall m . FuelMonad m => BwdRewrite m Insn Live
deadAsstElim = mkBRewrite d
where
......
......@@ -32,7 +32,7 @@ mapVN = mapEN . mapEE . mapVE
mapVE f (Var v) = f v
mapVE _ _ = Nothing
data Mapped a = Old a | New a
instance Monad Mapped where
......@@ -44,7 +44,7 @@ instance Monad Mapped where
instance Functor Mapped where
fmap = liftM
instance Applicative Mapped where
pure = return
(<*>) = ap
......@@ -71,7 +71,7 @@ class HasExpressions a where
instance HasExpressions (Insn e x) where
mapAllSubexpressions = error "urk!" (mapVars, (/@/), makeTotal, ifNew)
mapVars :: (Var -> Maybe Expr) -> Mapping Expr Expr
mapVars f e@(Var x) = makeTotalDefault e f x
mapVars _ e = return e
......@@ -80,7 +80,7 @@ mapVars _ e = return e
mapEE f e@(Lit _) = f e
mapEE f e@(Var _) = f e
mapEE f e@(Load addr) =
case mapEE f addr of
case mapEE f addr of
Just addr' -> Just $ fromMaybe e' (f e')
where e' = Load addr'
Nothing -> f e
......
......@@ -52,7 +52,7 @@ expr :: Parser Expr
expr = buildExpressionParser table factor
<?> "Expression"
where
table = [[op "*" (Binop Mul) AssocLeft, op "/" (Binop Div) AssocLeft],
table = [[op "*" (Binop Mul) AssocLeft, op "/" (Binop Div) AssocLeft],
[op "+" (Binop Add) AssocLeft, op "-" (Binop Sub) AssocLeft],
[op "=" (Binop Eq) AssocLeft, op "/=" (Binop Ne) AssocLeft,
op ">" (Binop Gt) AssocLeft, op "<" (Binop Lt) AssocLeft,
......@@ -73,7 +73,7 @@ lit = (natural >>= (return . Lit . Int))
<|> (bool >>= (return . Lit . Bool))
<|> (bool >>= (return . Lit . Bool))
<?> "lit"
loc :: Char -> Parser x -> Parser x
loc s addr = try (lexeme (do { char' s
; char' '['
......
......@@ -47,7 +47,7 @@ evalTest file =
Right s -> putStrLn s
optTest' :: M [Proc] -> ErrorM (M [Proc])
optTest' procs =
optTest' procs =
return $ procs >>= mapM optProc
where
optProc proc@(Proc {entry, body, args}) =
......@@ -55,7 +55,7 @@ optTest' procs =
(mapSingleton entry (initFact args))
; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty
; return $ proc { body = body'' } }
-- With debugging info:
-- With debugging info:
-- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit
-- , fp_rewrite = constProp `thenFwdRw` simplify }
fwd = constPropPass
......@@ -73,15 +73,15 @@ constPropPass = FwdPass
, fp_rewrite = constProp `thenFwdRw` simplify }
-- @ end cprop.tex
toAst :: [(IdLabelMap, Proc)] -> [A.Proc]
toAst l = fmap (uncurry Ia.irToAst) l
toAst :: [(IdLabelMap, Proc)] -> [A.Proc]
toAst l = fmap (uncurry Ia.irToAst) l
compareAst :: [A.Proc] -> [A.Proc] -> IO ()
compareAst [] [] = return ()
compareAst (r:results) (e:expected) =
if r == e
then compareAst results expected
else
else
do { putStrLn "expecting"
; putStrLn $ A.showProc e
; putStrLn "resulting"
......@@ -96,8 +96,8 @@ compareAst results expected = do { putStrLn "expecting"
; putStrLn "the result does not match the expected, abort the test!!!!"
; exitFailure
}
optTest :: String -> String -> IO ()
optTest file expectedFile =
......@@ -106,7 +106,7 @@ optTest file expectedFile =
case (parse file text, parse expectedFile expectedText) of
(Left err, _) -> putStrLn err
(_, Left err) -> putStrLn err
(Right lps, Right exps) ->
(Right lps, Right exps) ->
case optTest' (liftM (snd . unzip) lps) of
Left err -> putStrLn err
Right p -> do { let opted = runSimpleUniqueMonad $ runWithFuel fuel p
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment