Constant-propagation figure is now extracted automatically from John's code; some...
[packages/hoopl.git] / testing / OptSupport.hs
1 {-# LANGUAGE GADTs, RankNTypes #-}
2 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
3 module OptSupport (stdMapJoin, map_VE, map_EE, map_EN, map_VN, fold_EE, fold_EN, insnToG) where
4
5 import qualified Data.Map as M
6 import Data.Maybe
7 import Prelude hiding (succ)
8
9 import Compiler.Hoopl
10 import IR
11
12 ----------------------------------------------
13 -- Common lattice utility code:
14 ----------------------------------------------
15
16 -- It's common to represent dataflow facts as a map from locations
17 -- to some fact about the locations. For these maps, the join
18 -- operation on the map can be expressed in terms of the join
19 -- on each element:
20 stdMapJoin :: Ord k => JoinFun v -> JoinFun (M.Map k v)
21 stdMapJoin eltJoin l (OldFact old) (NewFact new) = M.foldWithKey add (NoChange, old) new
22 where
23 add k new_v (ch, joinmap) =
24 case M.lookup k joinmap of
25 Nothing -> (SomeChange, M.insert k new_v joinmap)
26 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
27 (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)
28 (NoChange, _) -> (ch, joinmap)
29
30 ----------------------------------------------
31 -- Map/Fold functions for expressions/insns
32 ----------------------------------------------
33
34 map_VE :: (Var -> Maybe Expr) -> (Expr -> Maybe Expr)
35 map_EE :: (Expr -> Maybe Expr) -> (Expr -> Maybe Expr)
36 map_EN :: (Expr -> Maybe Expr) -> (Insn e x -> Maybe (Insn e x))
37
38 map_VN :: (Var -> Maybe Expr) -> (Insn e x -> Maybe (Insn e x))
39 map_VN = map_EN . map_EE . map_VE
40
41 map_VE f (Var v) = f v
42 map_VE _ _ = Nothing
43
44
45 data Mapped a = Old a | New a
46 instance Monad Mapped where
47 return = Old
48 Old a >>= k = k a
49 New a >>= k = asNew (k a)
50 where asNew (Old a) = New a
51 asNew m@(New _) = m
52
53 makeTotal :: (a -> Maybe a) -> (a -> Mapped a)
54 makeTotal f a = case f a of Just a' -> New a'
55 Nothing -> Old a
56 makeTotalDefault :: b -> (a -> Maybe b) -> (a -> Mapped b)
57 makeTotalDefault b f a = case f a of Just b' -> New b'
58 Nothing -> Old b
59 ifNew :: Mapped a -> Maybe a
60 ifNew (New a) = Just a
61 ifNew (Old _) = Nothing
62
63 type Mapping a b = a -> Mapped b
64
65 (/@/) :: Mapping b c -> Mapping a b -> Mapping a c
66 f /@/ g = \x -> g x >>= f
67
68
69 class HasExpressions a where
70 mapAllSubexpressions :: Mapping Expr Expr -> Mapping a a
71
72 instance HasExpressions (Insn e x) where
73 mapAllSubexpressions = error "urk!" (mapVars, (/@/), makeTotal, ifNew)
74
75 mapVars :: (Var -> Maybe Expr) -> Mapping Expr Expr
76 mapVars f e@(Var x) = makeTotalDefault e f x
77 mapVars _ e = return e
78
79
80 map_EE f e@(Lit _) = f e
81 map_EE f e@(Var _) = f e
82 map_EE f e@(Load addr) =
83 case map_EE f addr of
84 Just addr' -> Just $ fromMaybe e' (f e')
85 where e' = Load addr'
86 Nothing -> f e
87 map_EE f e@(Binop op e1 e2) =
88 case (map_EE f e1, map_EE f e2) of
89 (Nothing, Nothing) -> f e
90 (e1', e2') -> Just $ fromMaybe e' (f e')
91 where e' = Binop op (fromMaybe e1 e1') (fromMaybe e2 e2')
92
93 map_EN _ (Label _) = Nothing
94 map_EN f (Assign v e) = fmap (Assign v) $ f e
95 map_EN f (Store addr e) =
96 case (f addr, f e) of
97 (Nothing, Nothing) -> Nothing
98 (addr', e') -> Just $ Store (fromMaybe addr addr') (fromMaybe e e')
99 map_EN _ (Branch _) = Nothing
100 map_EN f (Cond e tid fid) =
101 case f e of Just e' -> Just $ Cond e' tid fid
102 Nothing -> Nothing
103 map_EN f (Call rs n es succ) =
104 if all isNothing es' then Nothing
105 else Just $ Call rs n (map (uncurry fromMaybe) (zip es es')) succ
106 where es' = map f es
107 map_EN f (Return es) =
108 if all isNothing es' then Nothing
109 else Just $ Return (map (uncurry fromMaybe) (zip es es'))
110 where es' = map f es
111
112 fold_EE :: (a -> Expr -> a) -> a -> Expr -> a
113 fold_EN :: (a -> Expr -> a) -> a -> Insn e x -> a
114
115 fold_EE f z e@(Lit _) = f z e
116 fold_EE f z e@(Var _) = f z e
117 fold_EE f z e@(Load addr) = f (f z addr) e
118 fold_EE f z e@(Binop _ e1 e2) = f (f (f z e2) e1) e
119
120 fold_EN _ z (Label _) = z
121 fold_EN f z (Assign _ e) = f z e
122 fold_EN f z (Store addr e) = f (f z e) addr
123 fold_EN _ z (Branch _) = z
124 fold_EN f z (Cond e _ _) = f z e
125 fold_EN f z (Call _ _ es _) = foldl f z es
126 fold_EN f z (Return es) = foldl f z es
127
128 ----------------------------------------------
129 -- Lift a insn to a Graph
130 ----------------------------------------------
131
132 insnToG :: Insn e x -> Graph Insn e x
133 insnToG n@(Label _) = mkFirst n
134 insnToG n@(Assign _ _) = mkMiddle n
135 insnToG n@(Store _ _) = mkMiddle n
136 insnToG n@(Branch _) = mkLast n
137 insnToG n@(Cond _ _ _) = mkLast n
138 insnToG n@(Call _ _ _ _) = mkLast n
139 insnToG n@(Return _) = mkLast n