Abstracting collections of Uniques and Labels.
[packages/hoopl.git] / src / Compiler / Hoopl / Combinators.hs
1 {-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables #-}
2
3 module Compiler.Hoopl.Combinators
4 ( SimpleFwdRewrite, noFwdRewrite, thenFwdRw
5 , shallowFwdRw, shallowFwdRw', deepFwdRw, deepFwdRw', iterFwdRw
6 , SimpleBwdRewrite, SimpleBwdRewrite', noBwdRewrite, thenBwdRw
7 , shallowBwdRw, shallowBwdRw', deepBwdRw, deepBwdRw', iterBwdRw
8 , noRewritePoly
9 , productFwd, productBwd
10 )
11
12 where
13
14 import Data.Function
15 import Data.Maybe
16
17 import Compiler.Hoopl.Collections
18 import Compiler.Hoopl.Dataflow
19 import Compiler.Hoopl.Graph (C, O)
20 import Compiler.Hoopl.Label
21 import Compiler.Hoopl.MkGraph
22
23 type FR m n f = FwdRewrite m n f
24 type BR m n f = BwdRewrite m n f
25
26 type SFRW m n f e x = n e x -> f -> Maybe (AGraph m n e x)
27 type FRW m n f e x = n e x -> f -> Maybe (FwdRes m n f e x)
28 type SimpleFwdRewrite m n f = ExTriple (SFRW m n f)
29 type ExTriple a = (a C O, a O O, a O C) -- ^ entry/exit triple
30 type SimpleFwdRewrite' m n f = forall e x . SFRW m n f e x
31 type LiftFRW m n f e x = SFRW m n f e x -> FRW m n f e x
32 type MapFRW m n f e x = FRW m n f e x -> FRW m n f e x
33 type MapFRW2 m n f e x = FRW m n f e x -> FRW m n f e x -> FRW m n f e x
34
35 ----------------------------------------------------------------
36 -- common operations on triples
37
38 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
39 uncurry3 f (a, b, c) = f a b c
40
41 apply :: (a -> b, d -> e, g -> h) -> (a, d, g) -> (b, e, h)
42 apply (f1, f2, f3) (x1, x2, x3) = (f1 x1, f2 x2, f3 x3)
43
44 applyBinary :: (a -> b -> c, d -> e -> f, g -> h -> i)
45 -> (a, d, g) -> (b, e, h) -> (c, f, i)
46 applyBinary (f1, f2, f3) (x1, x2, x3) (y1, y2, y3) = (f1 x1 y1, f2 x2 y2, f3 x3 y3)
47
48
49 ----------------------------------------------------------------
50
51 wrapSFRewrites :: ExTriple (LiftFRW m n f) -> SimpleFwdRewrite m n f -> FR m n f
52 wrapSFRewrites lift rw = uncurry3 mkFRewrite $ apply lift rw
53
54 wrapFRewrites :: ExTriple (MapFRW m n f) -> FR m n f -> FR m n f
55 wrapFRewrites map frw = uncurry3 mkFRewrite $ apply map $ getFRewrites frw
56
57 wrapFRewrites2 :: ExTriple (MapFRW2 m n f) -> FR m n f -> FR m n f -> FR m n f
58 wrapFRewrites2 map frw1 frw2 =
59 uncurry3 mkFRewrite $ (applyBinary map `on` getFRewrites) frw1 frw2
60
61
62 -- Combinators for higher-rank rewriting functions:
63 wrapSFRewrites' :: (forall e x . LiftFRW m n f e x) -> SimpleFwdRewrite m n f -> FR m n f
64 wrapSFRewrites' lift = wrapSFRewrites (lift, lift, lift)
65
66 wrapFRewrites' :: (forall e x . MapFRW m n f e x) -> FR m n f -> FR m n f
67 wrapFRewrites' map = wrapFRewrites (map, map, map)
68
69 wrapFRewrites2' :: (forall e x . MapFRW2 m n f e x) -> FR m n f -> FR m n f -> FR m n f
70 wrapFRewrites2' map = wrapFRewrites2 (map, map, map)
71
72 ----------------------------------------------------------------
73
74 noFwdRewrite :: FwdRewrite m n f
75 noFwdRewrite = mkFRewrite' noRewritePoly
76
77 noRewritePoly :: a -> b -> Maybe c
78 noRewritePoly _ _ = Nothing
79
80 shallowFwdRw :: forall m n f . SimpleFwdRewrite m n f -> FwdRewrite m n f
81 shallowFwdRw rw = wrapSFRewrites' lift rw
82 where lift rw n f = fmap withoutRewrite (rw n f)
83 withoutRewrite ag = FwdRes ag noFwdRewrite
84
85 shallowFwdRw' :: SimpleFwdRewrite' m n f -> FwdRewrite m n f
86 shallowFwdRw' f = shallowFwdRw (f, f, f)
87
88 deepFwdRw :: SimpleFwdRewrite m n f -> FwdRewrite m n f
89 deepFwdRw' :: SimpleFwdRewrite' m n f -> FwdRewrite m n f
90 deepFwdRw r = iterFwdRw (shallowFwdRw r)
91 deepFwdRw' f = deepFwdRw (f, f, f)
92
93 thenFwdRw :: FwdRewrite m n f -> FwdRewrite m n f -> FwdRewrite m n f
94 thenFwdRw rw1 rw2 = wrapFRewrites2' f rw1 rw2
95 where f rw1 rw2' n f =
96 case rw1 n f of
97 Nothing -> rw2' n f
98 Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))
99
100 iterFwdRw :: FwdRewrite m n f -> FwdRewrite m n f
101 iterFwdRw rw = wrapFRewrites' f rw
102 where f rw' n f =
103 case rw' n f of
104 Just (FwdRes g rw2) -> Just $ FwdRes g (rw2 `thenFwdRw` iterFwdRw rw)
105 Nothing -> Nothing
106
107 ----------------------------------------------------------------
108
109 type SBRW m n f e x = n e x -> Fact x f -> Maybe (AGraph m n e x)
110 type BRW m n f e x = n e x -> Fact x f -> Maybe (BwdRes m n f e x)
111 type SimpleBwdRewrite m n f = ExTriple ( SBRW m n f)
112 type SimpleBwdRewrite' m n f = forall e x . SBRW m n f e x
113 type LiftBRW m n f e x = SBRW m n f e x -> BRW m n f e x
114 type MapBRW m n f e x = BRW m n f e x -> BRW m n f e x
115 type MapBRW2 m n f e x = BRW m n f e x -> BRW m n f e x -> BRW m n f e x
116
117 ----------------------------------------------------------------
118
119 wrapSBRewrites :: ExTriple (LiftBRW m n f) -> SimpleBwdRewrite m n f -> BwdRewrite m n f
120 wrapSBRewrites lift rw = uncurry3 mkBRewrite $ apply lift rw
121
122 wrapBRewrites :: ExTriple (MapBRW m n f) -> BwdRewrite m n f -> BwdRewrite m n f
123 wrapBRewrites map rw = uncurry3 mkBRewrite $ apply map $ getBRewrites rw
124
125 wrapBRewrites2 :: ExTriple (MapBRW2 m n f) -> BR m n f -> BR m n f -> BR m n f
126 wrapBRewrites2 map rw1 rw2 =
127 uncurry3 mkBRewrite $ (applyBinary map `on` getBRewrites) rw1 rw2
128
129 -- Combinators for higher-rank rewriting functions:
130 wrapSBRewrites' :: (forall e x . LiftBRW m n f e x) -> SimpleBwdRewrite m n f -> BR m n f
131 wrapSBRewrites' lift = wrapSBRewrites (lift, lift, lift)
132
133 wrapBRewrites' :: (forall e x . MapBRW m n f e x) -> BwdRewrite m n f -> BwdRewrite m n f
134 wrapBRewrites' map = wrapBRewrites (map, map, map)
135
136 wrapBRewrites2' :: (forall e x . MapBRW2 m n f e x) -> BR m n f -> BR m n f -> BR m n f
137 wrapBRewrites2' map = wrapBRewrites2 (map, map, map)
138
139 ----------------------------------------------------------------
140
141 noBwdRewrite :: BwdRewrite m n f
142 noBwdRewrite = mkBRewrite' $ \ _ _ -> Nothing
143
144 shallowBwdRw :: SimpleBwdRewrite m n f -> BwdRewrite m n f
145 shallowBwdRw rw = wrapSBRewrites' lift rw
146 where lift rw n f = fmap withoutRewrite (rw n f)
147 withoutRewrite ag = BwdRes ag noBwdRewrite
148
149 shallowBwdRw' :: SimpleBwdRewrite' m n f -> BwdRewrite m n f
150 shallowBwdRw' f = shallowBwdRw (f, f, f)
151
152 deepBwdRw :: SimpleBwdRewrite m n f -> BwdRewrite m n f
153 deepBwdRw' :: SimpleBwdRewrite' m n f -> BwdRewrite m n f
154 deepBwdRw r = iterBwdRw (shallowBwdRw r)
155 deepBwdRw' f = deepBwdRw (f, f, f)
156
157
158 thenBwdRw :: BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f
159 thenBwdRw rw1 rw2 = wrapBRewrites2' f rw1 rw2
160 where f rw1 rw2' n f =
161 case rw1 n f of
162 Nothing -> rw2' n f
163 Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))
164
165 iterBwdRw :: BwdRewrite m n f -> BwdRewrite m n f
166 iterBwdRw rw = wrapBRewrites' f rw
167 where f rw' n f =
168 case rw' n f of
169 Just (BwdRes g rw2) -> Just $ BwdRes g (rw2 `thenBwdRw` iterBwdRw rw)
170 Nothing -> Nothing
171
172 productFwd :: forall m n f f' . FwdPass m n f -> FwdPass m n f' -> FwdPass m n (f, f')
173 productFwd pass1 pass2 = FwdPass lattice transfer rewrite
174 where
175 lattice = productLattice (fp_lattice pass1) (fp_lattice pass2)
176 transfer = mkFTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
177 where
178 tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
179 tfb t1 t2 n (f1, f2) = mapWithKeyMap withfb2 fb1
180 where fb1 = t1 n f1
181 fb2 = t2 n f2
182 withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2)
183 bot2 = fact_bot (fp_lattice pass2)
184 (tf1, tm1, tl1) = getFTransfers (fp_transfer pass1)
185 (tf2, tm2, tl2) = getFTransfers (fp_transfer pass2)
186 rewrite = liftRW (fp_rewrite pass1) fst `thenFwdRw` liftRW (fp_rewrite pass2) snd
187 where
188 liftRW rws proj = mkFRewrite (lift f) (lift m) (lift l)
189 where lift rw n f = case rw n (proj f) of
190 Just (FwdRes g rws') -> Just (FwdRes g $ liftRW rws' proj)
191 Nothing -> Nothing
192 (f, m, l) = getFRewrites rws
193
194 productBwd :: forall m n f f' . BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f')
195 productBwd pass1 pass2 = BwdPass lattice transfer rewrite
196 where
197 lattice = productLattice (bp_lattice pass1) (bp_lattice pass2)
198 transfer = mkBTransfer (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2)
199 where
200 tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2)
201 tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb)
202 (tf1, tm1, tl1) = getBTransfers (bp_transfer pass1)
203 (tf2, tm2, tl2) = getBTransfers (bp_transfer pass2)
204 rewrite = liftRW (bp_rewrite pass1) fst `thenBwdRw` liftRW (bp_rewrite pass2) snd
205 where
206 liftRW :: forall f1 . BwdRewrite m n f1 -> ((f, f') -> f1) -> BwdRewrite m n (f, f')
207 liftRW rws proj = mkBRewrite (lift proj f) (lift proj m) (lift (mapMap proj) l)
208 where
209 lift proj' rw n f =
210 case rw n (proj' f) of
211 Just (BwdRes g rws') -> Just (BwdRes g $ liftRW rws' proj)
212 Nothing -> Nothing
213 (f, m, l) = getBRewrites rws
214
215 productLattice :: forall f f' . DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f')
216 productLattice l1 l2 =
217 DataflowLattice
218 { fact_name = fact_name l1 ++ " x " ++ fact_name l2
219 , fact_bot = (fact_bot l1, fact_bot l2)
220 , fact_extend = extend'
221 , fact_do_logging = fact_do_logging l1 || fact_do_logging l2
222 }
223 where
224 extend' lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2))
225 where (c1, f1) = fact_extend l1 lbl (OldFact o1) (NewFact n1)
226 (c2, f2) = fact_extend l2 lbl (OldFact o2) (NewFact n2)
227 c' = case (c1, c2) of
228 (NoChange, NoChange) -> NoChange
229 _ -> SomeChange