Change the block representation (version bumped to 3.9.0.0)
[packages/hoopl.git] / src / Compiler / Hoopl / XUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Trustworthy #-}
4 #endif
5
6 -- | Utilities for clients of Hoopl, not used internally.
7
8 module Compiler.Hoopl.XUtil
9 (
10 -- * Utilities for clients
11 distributeFact, distributeFactBwd
12 , successorFacts
13 , joinFacts
14 , joinOutFacts -- deprecated
15 , joinMaps
16 )
17 where
18
19 import qualified Data.Map as M
20 import Data.Maybe
21
22 import Compiler.Hoopl.Collections
23 import Compiler.Hoopl.Dataflow
24 import Compiler.Hoopl.Block
25 import Compiler.Hoopl.Graph
26 import Compiler.Hoopl.Label
27
28 -----------------------------------------------------------------------------
29
30 -- | Forward dataflow analysis and rewriting for the special case of a Body.
31 -- A set of entry points must be supplied; blocks not reachable from
32 -- the set are thrown away.
33 analyzeAndRewriteFwdBody
34 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
35 => FwdPass m n f
36 -> entries -> Body n -> FactBase f
37 -> m (Body n, FactBase f)
38
39 -- | Backward dataflow analysis and rewriting for the special case of a Body.
40 -- A set of entry points must be supplied; blocks not reachable from
41 -- the set are thrown away.
42 analyzeAndRewriteBwdBody
43 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
44 => BwdPass m n f
45 -> entries -> Body n -> FactBase f
46 -> m (Body n, FactBase f)
47
48 analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))
49 analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))
50
51 mapBodyFacts :: (Monad m)
52 => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f))
53 -> (Body n -> FactBase f -> m (Body n, FactBase f))
54 -- ^ Internal utility; should not escape
55 mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts
56 where -- the type constraint is needed for the pattern match;
57 -- if it were not, we would use do-notation here.
58 bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)
59 bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)
60
61 {-
62 Can't write:
63
64 do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f
65 return (body, fb)
66
67 because we need an explicit type signature in order to do the GADT
68 pattern matches on NothingO
69 -}
70
71
72
73 -- | Forward dataflow analysis and rewriting for the special case of a
74 -- graph open at the entry. This special case relieves the client
75 -- from having to specify a type signature for 'NothingO', which beginners
76 -- might find confusing and experts might find annoying.
77 analyzeAndRewriteFwdOx
78 :: forall m n f x. (CheckpointMonad m, NonLocal n)
79 => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f)
80
81 -- | Backward dataflow analysis and rewriting for the special case of a
82 -- graph open at the entry. This special case relieves the client
83 -- from having to specify a type signature for 'NothingO', which beginners
84 -- might find confusing and experts might find annoying.
85 analyzeAndRewriteBwdOx
86 :: forall m n f x. (CheckpointMonad m, NonLocal n)
87 => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f)
88
89 -- | A value that can be used for the entry point of a graph open at the entry.
90 noEntries :: MaybeC O Label
91 noEntries = NothingC
92
93 analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f
94 analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip
95 where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)
96 strip (a, b, JustO c) = return (a, b, c)
97
98
99
100
101
102 -- | A utility function so that a transfer function for a first
103 -- node can be given just a fact; we handle the lookup. This
104 -- function is planned to be made obsolete by changes in the dataflow
105 -- interface.
106
107 firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)
108 firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb
109
110 -- | This utility function handles a common case in which a transfer function
111 -- produces a single fact out of a last node, which is then distributed
112 -- over the outgoing edges.
113 distributeXfer :: NonLocal n
114 => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f)
115 distributeXfer lattice xfer n f =
116 mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
117
118
119 -- | This utility function handles a common case in which a transfer function
120 -- for a last node takes the incoming fact unchanged and simply distributes
121 -- that fact over the outgoing edges.
122 distributeFact :: NonLocal n => n O C -> f -> FactBase f
123 distributeFact n f = mapFromList [ (l, f) | l <- successors n ]
124 -- because the same fact goes out on every edge,
125 -- there's no need for 'mkFactBase' here.
126
127 -- | This utility function handles a common case in which a backward transfer
128 -- function takes the incoming fact unchanged and tags it with the node's label.
129 distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f
130 distributeFactBwd n f = mapSingleton (entryLabel n) f
131
132 -- | List of (unlabelled) facts from the successors of a last node
133 successorFacts :: NonLocal n => n O C -> FactBase f -> [f]
134 successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]
135
136 -- | Join a list of facts.
137 joinFacts :: DataflowLattice f -> Label -> [f] -> f
138 joinFacts lat inBlock = foldr extend (fact_bot lat)
139 where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new)
140
141 {-# DEPRECATED joinOutFacts
142 "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-}
143
144 joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f
145 joinOutFacts lat n f = foldr join (fact_bot lat) facts
146 where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new)
147 facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact]
148
149
150 -- | It's common to represent dataflow facts as a map from variables
151 -- to some fact about the locations. For these maps, the join
152 -- operation on the map can be expressed in terms of the join on each
153 -- element of the codomain:
154 joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)
155 joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new
156 where
157 add k new_v (ch, joinmap) =
158 case M.lookup k joinmap of
159 Nothing -> (SomeChange, M.insert k new_v joinmap)
160 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
161 (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)
162 (NoChange, _) -> (ch, joinmap)
163
164
165