add an FAQ file
[packages/hoopl.git] / prototypes / CunningTransfers.hs
1 {-# LANGUAGE ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards #-}
2
3 module CunningTransfers where
4
5 import qualified Data.IntMap as M
6 import qualified Data.IntSet as S
7
8 -----------------------------------------------------------------------------
9 -- BlockId, BlockEnv, BlockSet
10 -----------------------------------------------------------------------------
11
12 type BlockId = Int
13
14 mkBlockId :: Int -> BlockId
15 mkBlockId uniq = uniq
16
17 type BlockEnv a = M.IntMap a
18
19 mkBlockEnv :: [(BlockId, a)] -> BlockEnv a
20 mkBlockEnv prs = M.fromList prs
21
22 lookupBEnv :: BlockEnv f -> BlockId -> Maybe f
23 lookupBEnv env blk_id = M.lookup blk_id env
24
25 extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f
26 extendBEnv env blk_id f = M.insert blk_id f env
27
28 type BlockSet = S.IntSet
29
30 emptyBlockSet :: BlockSet
31 emptyBlockSet = S.empty
32
33 extendBlockSet :: BlockSet -> BlockId -> BlockSet
34 extendBlockSet bids bid = S.insert bid bids
35
36 elemBlockSet :: BlockId -> BlockSet -> Bool
37 elemBlockSet bid bids = S.member bid bids
38
39 -----------------------------------------------------------------------------
40 -- Graphs
41 -----------------------------------------------------------------------------
42
43 data ZOpen
44 data ZClosed
45
46 type O = ZOpen
47 type C = ZClosed
48
49 data ZBlock e x m l where
50 ZFirst :: BlockId -> ZBlock C O m l
51 ZMid :: m -> ZBlock O O m l
52 ZLast :: l -> ZBlock O C m l
53 ZCat :: ZBlock e O m l -> ZBlock O x m l -> ZBlock e x m l
54
55 type ZHead = ZBlock C O
56 type ZMids = ZBlock O O
57 type ZTail = ZBlock O C
58 type Block = ZBlock C C
59
60 data ZGraph e x m l where
61 ZGMany { zg_entry :: ZBlock e C m l
62 , zg_blocks :: BlockEnv (Block m l)
63 , zg_exit :: ZBlock C x m l } :: ZGraph e x m l
64 ZGOne { zg_mids :: ZMids m l } :: ZGraph O O m l
65 ZGNil :: ZGraph O O m l
66
67 type Graph = ZGraph C C
68
69 forwardBlockList :: BlockEnv (Block m l) -> [(BlockId, Block m l)]
70 -- This produces a list of blocks in order suitable for forward analysis.
71 -- ToDo: Do a topological sort to improve convergence rate of fixpoint
72 -- This will require a (HavingSuccessors l) class constraint
73 forwardBlockList env = M.toList env
74
75 -----------------------------------------------------------------------------
76 -- DataflowLattice
77 -----------------------------------------------------------------------------
78
79 data DataflowLattice a = DataflowLattice {
80 fact_name :: String, -- Documentation
81 fact_bot :: a, -- Lattice bottom element
82 fact_add_to :: a -> a -> TxRes a, -- Lattice join plus change flag
83 fact_do_logging :: Bool -- log changes
84 }
85
86 -----------------------------------------------------------------------------
87 -- TxRes and ChangeFlags
88 -----------------------------------------------------------------------------
89
90 data ChangeFlag = NoChange | SomeChange
91 data TxRes a = TxRes ChangeFlag a
92
93
94 -----------------------------------------------------------------------------
95 -- The main Hoopl API
96 -----------------------------------------------------------------------------
97
98 data ForwardTransfers m l f
99 = ForwardTransfers
100 { ft_lattice :: DataflowLattice f
101 , ft_first :: BlockId -> f -> f
102 , ft_middle :: m -> f -> f
103 , ft_last :: l -> f -> OutFacts f
104 }
105
106 data ForwardRewrites m l f
107 = ForwardRewrites
108 { fr_first :: BlockId -> f -> Maybe (AGraph C O m l)
109 , fr_middle :: m -> f -> Maybe (AGraph O O m l)
110 , fr_last :: l -> f -> Maybe (AGraph O C m l)
111 , fr_exit :: f -> Maybe (AGraph O O m l)
112 }
113
114 data AGraph e x m l = AGraph -- Stub for now
115
116 -----------------------------------------------------------------------------
117 -- The FactBase
118 -----------------------------------------------------------------------------
119
120 type FactBase fact = BlockEnv fact
121
122 getFact :: DataflowLattice fact -> FactBase fact -> BlockId -> fact
123 getFact lat fb id = lookupBEnv fb id `orElse` fact_bot lat
124
125
126 -----------------------------------------------------------------------------
127 -- TxFactBase: a FactBase with ChangeFlag information
128 -----------------------------------------------------------------------------
129
130 -- A TxFactBase carries a ChangeFlag with it, and a set of BlockIds
131 -- to monitor. Updates to other BlockIds don't affect the ChangeFlag
132 data TxFactBase fact
133 = TxFB { tfb_fbase :: FactBase fact
134 , tfb_cha :: ChangeFlag
135 , tfb_bids :: BlockSet -- Update change flag iff these blocks change
136 }
137
138 updateFact :: DataflowLattice f -> (BlockId, f)
139 -> TxFactBase f -> TxFactBase f
140 -- Update a TxFactBase, setting the change flag iff
141 -- a) the new fact adds information...
142 -- b) for a block in the BlockSet in the TxFactBase
143 updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
144 | NoChange <- cha2 = tx_fb
145 | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
146 | otherwise = tx_fb { tfb_fbase = new_fbase }
147 where
148 old_fact = lookupBEnv fbase bid `orElse` fact_bot lat
149 TxRes cha2 res_fact = fact_add_to lat old_fact new_fact
150 new_fbase = extendBEnv fbase bid res_fact
151
152 updateFacts :: DataflowLattice f -> BlockId
153 -> Trans (FactBase f) (OutFacts f)
154 -> Trans (TxFactBase f) (TxFactBase f)
155 updateFacts lat bid thing_inside tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids })
156 = do { OutFacts out_facts <- thing_inside fbase
157 ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid }
158 ; return (foldr (updateFact lat) tx_fb out_facts) }
159
160 -----------------------------------------------------------------------------
161 -- The Trans arrow
162 -----------------------------------------------------------------------------
163
164 type Trans a b = a -> FuelMonad b
165 -- Transform a into b, with facts of type f
166 -- Deals with optimsation fuel and unique supply too
167
168 (>>>) :: Trans a b -> Trans b c -> Trans a c
169 -- Compose two dataflow transfers in sequence
170 (dft1 >>> dft2) f1 = do { f2 <- dft1 f1; dft2 f2 }
171
172 liftTrans :: (a->b) -> Trans a b
173 liftTrans f x = return (f x)
174
175 idTrans :: Trans a a
176 idTrans x = return x
177
178 fixpointTrans :: forall f. Trans (TxFactBase f) (TxFactBase f)
179 -> Trans (OutFacts f) (FactBase f)
180 fixpointTrans thing_inside (OutFacts out_facts)
181 = loop (mkBlockEnv out_facts)
182 where
183 loop :: Trans (FactBase f) (FactBase f)
184 loop fbase = do { tx_fb <- thing_inside (TxFB { tfb_fbase = fbase
185 , tfb_cha = NoChange
186 , tfb_bids = emptyBlockSet })
187 ; case tfb_cha tx_fb of
188 NoChange -> return fbase
189 SomeChange -> loop (tfb_fbase tx_fb) }
190
191 -----------------------------------------------------------------------------
192 -- Transfer functions
193 -----------------------------------------------------------------------------
194
195 -- Keys to the castle: a generic transfer function for each shape
196 -- Here's the idea: we start with single-node transfer functions,
197 -- move to basic-block transfer functions (we have exactly four shapes),
198 -- then finally to graph transfer functions (which requires iteration).
199
200 data GFT co oo oc cc fact
201 = GFT { gft_lat :: DataflowLattice fact
202 , gft_co :: co -> Trans (FactBase fact) fact
203 , gft_oo :: oo -> Trans fact fact
204 , gft_oc :: oc -> Trans fact (OutFacts fact)
205 , gft_cc :: cc -> Trans (FactBase fact) (OutFacts fact) }
206
207 newtype OutFacts fact = OutFacts [(BlockId, fact)]
208
209
210 ----------------------------------------------------------------------------------------------
211 -- closed/open open/open open/closed closed/closed
212 ----------------------------------------------------------------------------------------------
213 type GFT_Node m l f = GFT BlockId m l Void f
214 type GFT_Block m l f = GFT (ZHead m l) (ZMids m l) (ZTail m l) (Block m l) f
215 type GFT_Graph m l f = GFT (ZGraph C O m l) (ZGraph O O m l) (ZGraph O C m l) (ZGraph C C m l) f
216 ----------------------------------------------------------------------------------------------
217
218 data Void -- There is no closed/closed node
219
220 gftNode :: forall m l f . ForwardTransfers m l f -> GFT_Node m l f
221 -- Injection from the external interface into the internal representation
222 gftNode (ForwardTransfers { ft_lattice = lattice
223 , ft_first = first_fn
224 , ft_middle = middle_fn
225 , ft_last = last_fn })
226 = GFT { gft_lat = lattice
227 , gft_co = ft_first
228 , gft_oo = ft_middle
229 , gft_oc = ft_last
230 , gft_cc = error "f_cc for node is undefined" }
231 where
232 ft_first blk_id fb = return (first_fn blk_id (getFact lattice fb blk_id))
233 ft_middle node fact = return (middle_fn node fact)
234 ft_last node fact = return (last_fn node fact)
235
236 gftBlock :: forall m l f. GFT_Node m l f -> GFT_Block m l f
237 -- Lift from nodes to blocks
238 gftBlock (GFT { gft_lat = lat, gft_co = ft_first
239 , gft_oo = ft_middle, gft_oc = ft_last })
240 = GFT { gft_lat = lat
241 , gft_co = ft_head
242 , gft_oo = ft_mids
243 , gft_oc = ft_tail
244 , gft_cc = ft_block }
245 where
246 ft_head :: ZBlock C O m l -> Trans (FactBase f) f
247 ft_head (ZFirst blk_id) = ft_first blk_id
248 ft_head (ZCat head mids) = ft_head head >>> ft_mids mids
249
250 ft_mids :: ZBlock O O m l -> Trans f f
251 ft_mids (ZMid node) = ft_middle node
252 ft_mids (ZCat m1 m2) = ft_mids m1 >>> ft_mids m2
253
254 ft_tail :: ZBlock O C m l -> Trans f (OutFacts f)
255 ft_tail (ZLast node) = ft_last node
256 ft_tail (ZCat mids tail) = ft_mids mids >>> ft_tail tail
257
258 ft_block :: ZBlock C C m l -> Trans (FactBase f) (OutFacts f)
259 ft_block (ZCat head tail) = ft_head head >>> ft_tail tail
260
261 gftGraph :: forall m l f. GFT_Block m l f -> GFT_Graph m l f
262 -- Lift from blocks to graphs
263 gftGraph (GFT { gft_lat = lat
264 , gft_co = ft_head, gft_oo = ft_mids
265 , gft_oc = ft_tail, gft_cc = ft_block })
266 = GFT { gft_lat = lat
267 , gft_co = ft_co
268 , gft_oo = ft_oo
269 , gft_oc = ft_oc
270 , gft_cc = ft_cc }
271 where
272 -- These functions are orgasmically beautiful
273 ft_co :: ZGraph C O m l -> Trans (FactBase f) f
274 ft_co (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })
275 = ft_block entry >>> ft_blocks blocks >>> ft_head exit
276
277 ft_oo :: ZGraph O O m l -> Trans f f
278 ft_oo ZGNil = idTrans
279 ft_oo (ZGOne mids) = ft_mids mids
280 ft_oo (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })
281 = ft_tail entry >>> ft_blocks blocks >>> ft_head exit
282
283 ft_oc :: ZGraph O C m l -> Trans f (OutFacts f)
284 ft_oc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })
285 = ft_tail entry >>> ft_blocks blocks >>> ft_block exit
286
287 ft_cc :: ZGraph C C m l -> Trans (FactBase f) (OutFacts f)
288 ft_cc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit })
289 = ft_block entry >>> ft_blocks blocks >>> ft_block exit
290
291 ft_blocks :: BlockEnv (Block m l) -> Trans (OutFacts f) (FactBase f)
292 ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))
293
294 ft_blocks_once :: [(BlockId, Block m l)] -> Trans (TxFactBase f) (TxFactBase f)
295 ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks
296
297 ft_block_once :: (BlockId, Block m l)
298 -> Trans (TxFactBase f) (TxFactBase f)
299 ft_block_once (blk_id, blk) = updateFacts lat blk_id (ft_block blk)
300
301
302 -----------------------------------------------------------------------------
303 -- Rewriting
304 -----------------------------------------------------------------------------
305
306 {-
307 data GRT co oo oc cc fact
308 = GRT { grt_lat :: DataflowLattice fact
309 , grt_co :: co -> Trans (FactBase fact) (fact, Graph C O m l)
310 , grt_oo :: oo -> Trans fact (fact, Graph O O m l)
311 , grt_oc :: oc -> Trans fact (OutFacts fact)
312 , gRt_cc :: cc -> Trans (FactBase fact) (OutFacts fact) }
313 -}
314
315 -----------------------------------------------------------------------------
316 -- The fuel monad
317 -----------------------------------------------------------------------------
318
319 type Uniques = Int
320 type Fuel = Int
321
322 newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
323
324 instance Monad FuelMonad where
325 return x = FM (\f u -> (x,f,u))
326 m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
327
328 fuelExhausted :: FuelMonad Bool
329 fuelExhausted = FM (\f u -> (f <= 0, f, u))
330
331 decrementFuel :: FuelMonad ()
332 decrementFuel = FM (\f u -> ((), f-1, u))
333
334 graphOfAGraph :: AGraph e x m l -> FuelMonad (ZGraph e x m l)
335 graphOfAGraph = error "urk" -- Stub
336
337 -----------------------------------------------------------------------------
338 -- Utility functions
339 -----------------------------------------------------------------------------
340
341 orElse :: Maybe a -> a -> a
342 orElse (Just x) _ = x
343 orElse Nothing y = y
344
345
346
347 ----------------------------------------------------------------
348 -- The pi├Ęce de resistance: cunning transfer functions
349 ----------------------------------------------------------------
350
351 pureAnalysis :: ForwardTransfers m l f -> GFT_Graph m l f
352 pureAnalysis = gftGraph . gftBlock . gftNode
353
354 analyseAndRewrite
355 :: forall m l f .
356 RewritingDepth
357 -> ForwardTransfers m l f
358 -> ForwardRewrites m l f
359 -> GFT_Graph m l f
360
361 data RewritingDepth = RewriteShallow | RewriteDeep
362 -- When a transformation proposes to rewrite a node,
363 -- you can either ask the system to
364 -- * "shallow": accept the new graph, analyse it without further rewriting
365 -- * "deep": recursively analyse-and-rewrite the new graph
366
367
368 analyseAndRewrite depth transfers rewrites
369 = gft_graph_cunning
370 where
371 lat = ft_lattice transfers
372
373 gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph m l f
374
375 gft_graph_base = gftGraph (gftBlock gft_node_base)
376 gft_graph_cunning = gftGraph (gftBlock gft_node_cunning)
377 gft_graph_recurse = case depth of
378 RewriteShallow -> gft_graph_base
379 RewriteDeep -> gft_graph_cunning
380
381 gft_node_base, gft_node_cunning :: GFT_Node m l f
382 gft_node_base = gftNode transfers
383 gft_node_cunning = GFT { gft_lat = lat
384 , gft_co = cunning_first
385 , gft_oo = cunning_middle
386 , gft_oc = cunning_last
387 , gft_cc = error "f_cc for node is undefined" }
388
389 cunning_first :: BlockId -> Trans (FactBase f) f
390 cunning_first bid = tryRewrite (rw_first bid)
391 (gft_co gft_graph_recurse)
392 (gft_co gft_node_base bid)
393
394 rw_first :: BlockId -> FactBase f -> Maybe (AGraph C O m l)
395 rw_first bid fb = fr_first rewrites bid (getFact lat fb bid)
396
397 cunning_middle :: m -> Trans f f
398 cunning_middle mid = tryRewrite (fr_middle rewrites mid)
399 (gft_oo gft_graph_recurse)
400 (gft_oo gft_node_base mid)
401
402 cunning_last :: l -> Trans f (OutFacts f)
403 cunning_last last = tryRewrite (fr_last rewrites last)
404 (gft_oc gft_graph_recurse)
405 (gft_oc gft_node_base last)
406
407 -----------
408 tryRewrite :: (a -> (Maybe (AGraph e x m l))) -- The rewriter
409 -> (ZGraph e x m l -> Trans a r) -- Rewrite succeeds
410 -> Trans a r -- Rewrite fails
411 -> Trans a r
412 tryRewrite rewriter do_yes do_no a
413 = case (rewriter a) of
414 Nothing -> do_no a
415 Just g -> do { out <- fuelExhausted
416 ; if out then do_no a
417 else do { decrementFuel
418 ; g' <- graphOfAGraph g
419 ; do_yes g' a } }