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