0008da87de49025636c67a043a1bce45035c8ac2
[packages/hoopl.git] / testing / OptSupport.hs
1 {-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns -XGADTs -XRankNTypes #-}
2 module OptSupport (stdMapJoin, map_VE, map_EE, map_EN, fold_EE, fold_EN, insnToG) where
3
4 import qualified Data.Map as M
5 import Data.Maybe
6 import Prelude hiding (succ)
7
8 import Compiler.Hoopl
9 import IR
10
11 ----------------------------------------------
12 -- Common lattice utility code:
13 ----------------------------------------------
14
15 -- It's common to represent dataflow facts as a map from locations
16 -- to some fact about the locations. For these maps, the join
17 -- operation on the map can be expressed in terms of the join
18 -- on each element:
19 stdMapJoin :: Ord k => JoinFun v -> JoinFun (M.Map k v)
20 stdMapJoin eltJoin l (OldFact old) (NewFact new) = M.foldWithKey add (NoChange, old) new
21 where
22 add k new_v (ch, joinmap) =
23 case M.lookup k joinmap of
24 Nothing -> (SomeChange, M.insert k new_v joinmap)
25 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
26 (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)
27 (NoChange, _) -> (ch, joinmap)
28
29 ----------------------------------------------
30 -- Map/Fold functions for expressions/insns
31 ----------------------------------------------
32
33 map_VE :: (Var -> Maybe Expr) -> (Expr -> Maybe Expr)
34 map_EE :: (Expr -> Maybe Expr) -> (Expr -> Maybe Expr)
35 map_EN :: (Expr -> Maybe Expr) -> (Insn e x -> Maybe (Insn e x))
36
37 map_VE f (Var v) = f v
38 map_VE _ _ = Nothing
39
40
41
42 map_EE f e@(Lit _) = f e
43 map_EE f e@(Var _) = f e
44 map_EE f e@(Load addr) =
45 case map_EE f addr of
46 Just addr' -> Just $ fromMaybe e' (f e')
47 where e' = Load addr'
48 Nothing -> f e
49 map_EE f e@(Binop op e1 e2) =
50 case (map_EE f e1, map_EE f e2) of
51 (Nothing, Nothing) -> f e
52 (e1', e2') -> Just $ fromMaybe e' (f e')
53 where e' = Binop op (fromMaybe e1 e1') (fromMaybe e2 e2')
54
55 map_EN _ (Label _) = Nothing
56 map_EN f (Assign v e) = fmap (Assign v) $ f e
57 map_EN f (Store addr e) =
58 case (f addr, f e) of
59 (Nothing, Nothing) -> Nothing
60 (addr', e') -> Just $ Store (fromMaybe addr addr') (fromMaybe e e')
61 map_EN _ (Branch _) = Nothing
62 map_EN f (Cond e tid fid) =
63 case f e of Just e' -> Just $ Cond e' tid fid
64 Nothing -> Nothing
65 map_EN f (Call rs n es succ) =
66 if all isNothing es' then Nothing
67 else Just $ Call rs n (map (uncurry fromMaybe) (zip es es')) succ
68 where es' = map f es
69 map_EN f (Return es) =
70 if all isNothing es' then Nothing
71 else Just $ Return (map (uncurry fromMaybe) (zip es es'))
72 where es' = map f es
73
74 fold_EE :: (a -> Expr -> a) -> a -> Expr -> a
75 fold_EN :: (a -> Expr -> a) -> a -> Insn e x -> a
76
77 fold_EE f z e@(Lit _) = f z e
78 fold_EE f z e@(Var _) = f z e
79 fold_EE f z e@(Load addr) = f (f z addr) e
80 fold_EE f z e@(Binop _ e1 e2) = f (f (f z e2) e1) e
81
82 fold_EN _ z (Label _) = z
83 fold_EN f z (Assign _ e) = f z e
84 fold_EN f z (Store addr e) = f (f z e) addr
85 fold_EN _ z (Branch _) = z
86 fold_EN f z (Cond e _ _) = f z e
87 fold_EN f z (Call _ _ es _) = foldl f z es
88 fold_EN f z (Return es) = foldl f z es
89
90 ----------------------------------------------
91 -- Lift a insn to a Graph
92 ----------------------------------------------
93
94 insnToG :: Insn e x -> Graph Insn e x
95 insnToG n@(Label _) = mkFirst n
96 insnToG n@(Assign _ _) = mkMiddle n
97 insnToG n@(Store _ _) = mkMiddle n
98 insnToG n@(Branch _) = mkLast n
99 insnToG n@(Cond _ _ _) = mkLast n
100 insnToG n@(Call _ _ _ _) = mkLast n
101 insnToG n@(Return _) = mkLast n