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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
{-
Kaya - My favourite toy language.
Copyright (C) 2004-2007 Edwin Brady
This file is distributed under the terms of the GNU General
Public Licence. See COPYING for licence.
-}
module Dataflow where
-- Dataflow analysis, identifying interferences between local variables
-- (so that we can work out which to drop and which to reuse)
-- FIXME: This module is COMPLETELY BROKEN!
import Control.Monad.State
import Data.List
import Language
type Edge = (Loc, Loc) -- two names which interfere, order doesn't matter
type Graph = [Edge]
type Loc = Int
addEdge :: Loc -> Loc -> Graph -> Graph
addEdge x y es | x<y = nub ((x,y):es)
| x==y = es
| x>y = nub ((y,x):es)
-- A name is active from when it is assigned to, until the last point it is
-- referenced before it is next assigned to. Any variables active at the
-- end of a while/do/for loop should also be counted as active at the start.
-- Any two variables active at the same time (with the sole exception of a
-- direct assignment x=y) are connected in the interference graph
-- If a variable is active at the start of a condition block, it also might
-- be active at the end if the block is skipped.
-- We analyse this by traversing an expression, effectively flattening it,
-- making a note of the point at which assignments and uses happen.
-- From that data, we can work out where there are overlapping uses.
data VarInfo = Assigned Loc Int -- assigned to name at location in code
| Moved Loc Loc Int -- name is assigned from another name at loc
| Used Loc Int -- name is accessed at location in code
| Loop Int Int -- a loop entry point and exit point
| Condition Int Int -- a conditional block span
deriving (Show, Eq)
-- Order based on location
instance Ord VarInfo where
compare x y = compare (loc x) (loc y)
where loc (Assigned _ l) = l
loc (Moved _ _ l) = l
loc (Used _ l) = l
loc (Loop s e) = s
loc (Condition s e) = s
type VarState = (Int, -- program counter
Int, -- number of locals
[VarInfo]) -- what happens
addVS v = do (pc, locs, vs) <- get
put (pc+1, locs, ((v pc):vs))
addPC = do (pc, locs, vs) <- get
put (pc+1, locs, vs)
return pc
addLoc = do (pc, locs, vs) <- get
put (pc, locs+1, vs)
return locs -- return variable number
-- Create a list of what happens to each variable. Make a note that 'var'
-- args are additionally used at the end of the function (their value is put
-- back where the caller's value was)
findInfo :: [ArgType] -> Expr Name -> (Int, [VarInfo])
findInfo ivs e = let (pc, numVars, st) = execState (findVarInfo e) (0, 0, [])
in (numVars, sort (st ++ useVars 0 pc ivs))
where useVars i pc (Var:xs) = (Used i pc):(useVars (i+1) (pc+1) xs)
useVars i pc (_:xs) = useVars (i+1) (pc+1) xs
useVars i pc [] = []
findVarInfo :: Expr Name -> State VarState ()
-- Interesting cases first
findVarInfo (Loc i) = addVS $ Used i
findVarInfo (Assign (AName i) (Loc j)) = addVS $ Moved j i
findVarInfo (Assign (AName i) e) = do findVarInfo e
addVS $ Assigned i
findVarInfo (Assign a e) = do findVarInfo e
findAInfo a
findVarInfo (AssignOp op a e)
= do findVarInfo e
case a of
(AName i) -> addVS $ Assigned i
_ -> findAInfo a
findVarInfo (AssignApp a e)
= do findVarInfo e
case a of
(AName i) -> addVS $ Assigned i
_ -> findAInfo a
findVarInfo (Case e alts) = do findVarInfo e
mapM_ findAltInfo alts
where findAltInfo (Alt _ _ args res) = -- assign to args, run res
do mapM_ findArgInfo args
findVarCond res
findAltInfo (ConstAlt _ _ e) = findVarCond e
findAltInfo (ArrayAlt es e) =
do mapM_ findArgInfo es
findVarCond e
findAltInfo (Default e) = findVarCond e
findArgInfo (Loc i) = addVS $ Assigned i
findArgInfo _ = return ()
findVarInfo (While e b) = do pcStart <- addPC
findVarInfo e
findVarInfo b
addVS $ Loop pcStart
findVarInfo (DoWhile e b) = do pcStart <- addPC
findVarInfo b
findVarInfo e
addVS $ Loop pcStart
findVarInfo (For i _ j a init body)
= do findVarInfo init
pcStart <- addPC
addVS $ Assigned i
addVS $ Assigned j
addVS $ Used i -- always used to keep the loop counter up to date
addVS $ Used j -- always used to look up values from
case a of
(AName av) -> addVS $ Assigned av
_ -> findAInfo a
findVarInfo body
addVS $ Loop pcStart
findVarInfo (If a t e) = do findVarInfo a
findVarCond t
findVarCond e
findVarInfo (Bind _ _ e1 e2) = do findVarInfo e1
v <- addLoc
addVS $ Assigned v
findVarInfo e2
findVarInfo (Declare _ _ _ _ e) = do addLoc
findVarInfo e
findVarInfo (NewTryCatch t cs) = do findVarInfo t
mapM_ findCatchInfo cs
where findCatchInfo (Catch (Left (_,args)) h) = do mapM_ findArgInfo args
findVarCond h
findCatchInfo (Catch (Right n) h) = do findArgInfo n
findVarCond h
findArgInfo (Loc i) = addVS $ Assigned i
findArgInfo _ = return ()
-- Arguments are evaluated before the function.
-- Arguments *may* be assigned to, in the case of a var function, but
-- the safe thing to do is to assume they aren't.
findVarInfo (Apply f es) = do mapM_ findVarInfo es ; findVarInfo f
findVarInfo (Foreign t n es) = mapM_ findVarInfo (map fst es)
-- Everything else structural
findVarInfo (Lambda _ _ e) = findVarInfo e
findVarInfo (Closure _ _ e) = findVarInfo e -- should have been lifted by now!
findVarInfo (Return e) = findVarInfo e
findVarInfo (Seq x y) = do findVarInfo x ; findVarInfo y
findVarInfo (ConApply f es) = do mapM_ findVarInfo es ; findVarInfo f
findVarInfo (Partial b f es _) = do mapM_ findVarInfo es ; findVarInfo f
findVarInfo (Throw e) = findVarInfo e
findVarInfo (NewExcept es) = mapM_ findVarInfo es
findVarInfo (Infix op l r) = do findVarInfo l
findVarInfo r
findVarInfo (RealInfix op l r) = do findVarInfo l
findVarInfo r
findVarInfo (CmpExcept _ l r) = do findVarInfo l
findVarInfo r
findVarInfo (CmpStr _ l r) = do findVarInfo l
findVarInfo r
findVarInfo (Append l r) = do findVarInfo l
findVarInfo r
findVarInfo (AppendChain es) = mapM_ findVarInfo es
findVarInfo (Unary _ e) = findVarInfo e
findVarInfo (RealUnary _ e) = findVarInfo e
findVarInfo (Coerce _ _ e) = findVarInfo e
findVarInfo (Index v i) = do findVarInfo i
findVarInfo v
findVarInfo (Field e _ _ _) = findVarInfo e
findVarInfo (ArrayInit es) = mapM_ findVarInfo es
findVarInfo (Length e) = findVarInfo e
findVarInfo (Annotation _ e) = findVarInfo e
findVarInfo _ = return ()
-- Helper for assigns
findAInfo (AName i) = -- looking inside, so it's a use not an assign
addVS $ Used i
findAInfo (AIndex a e) = do findVarInfo e
findAInfo a
findAInfo (AField a _ _ _) = findAInfo a
findAInfo _ = return ()
-- Helpfer for conditional blocks
findVarCond a = do cStart <- addPC
findVarInfo a
addVS $ Condition cStart
-- Now do some useful things with this information
-- Easy one: Spot variables which are assigned but never used. We can drop
-- all assignments to this.
-- XXXXX: Actually, Propagate.hs does this a much simpler way...
neverUsed :: Int -> [VarInfo] -> [Int]
neverUsed 0 _ = []
neverUsed i vs = case filter (isUsed (i-1)) vs of
[] -> (i-1):(neverUsed (i-1) vs)
(_:_) -> neverUsed (i-1) vs
isUsed i (Used j _) | i == j = True
isUsed i (Moved j _ _) | i == j = True
isUsed _ _ = False
|
