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