2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Cyclic]{Knot tying}
6 >#include "HsVersions.h"
9 > mkLoops, fixupFreeVars
14 > import Def2Core ( d2c, defPanic )
16 > import Type ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTys,
19 > import Digraph ( dfs )
20 > import Id ( idType, toplevelishId, updateIdType,
21 > getIdInfo, replaceIdInfo, eqId, Id
24 > import Maybes ( Maybe(..) )
30 -----------------------------------------------------------------------------
31 A more efficient representation for lists that are extended multiple
32 times, but only examined once.
34 > type FList a = [a] -> [a]
37 > cons x xs = \ys -> x:(xs ys)
41 -----------------------------------------------------------------------------
42 Monad for the knot-tier.
44 > type Lbl a = UniqSM (
45 > [(Id)], -- loops used
46 > [(Id,DefExpr,[Id],DefExpr)], -- bindings floating upwards
47 > [(Id,DefExpr)], -- back loops
48 > a) -- computation result
50 > thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b
52 > = a `thenUs` \(ls, bs, bls, a) ->
53 > k a `thenUs` \(ls',bs',bls', b) ->
54 > returnUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
56 > returnLbl :: a -> Lbl a
57 > returnLbl a = returnUs ([],[],[],a)
59 > mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b]
60 > mapLbl f [] = returnLbl []
62 > = f x `thenLbl` \x ->
63 > mapLbl f xs `thenLbl` \xs ->
66 -----------------------------------------------------------------------------
68 This is terribly inefficient.
70 > mkLoops :: DefExpr -> UniqSM ([(Id,DefExpr)],DefExpr)
74 > loop [] e `thenUs` \(ls,bs,bls,e) ->
76 Throw away all the extracted bindings that can't be reached. These
77 can occur as the result of some forward loops being short-circuited by
78 back-loops. We find out which bindings can be reached by a
79 depth-first search of the call graph starting with the free variables
80 of the expression being returned.
83 > loops_out = filter deforestable (freeVars e)
84 > (_,reachable) = dfs (==) r ([],[]) loops_out
88 > lookup f ((g,out,_):xs) | f == g = out
89 > | otherwise = lookup f xs
91 > isReachable (f,_,_) = f `elem` reachable
93 > returnUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
96 > loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
98 > loop ls (Var (Label e e1))
100 > d2c e `thenUs` \core_e ->
101 >-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
103 > mapUs (\(f,e',val_args,ty_args) ->
104 > renameExprs e' e `thenUs` \r ->
105 > returnUs (f,val_args,ty_args,r)) ls `thenUs` \results ->
108 > [ (f,val_args,ty_args,r) |
109 > (f,val_args,ty_args,IsRenaming r) <- results ]
110 > inconsistent_renamings =
112 > (f,val_args,ty_args,InconsistentRenaming r)
119 Ok, there are no loops (i.e. this expression hasn't occurred before).
120 Prepare for a possible re-occurrence of *this* expression, by making
121 up a new function name and type (laziness ensures that this isn't
122 actually done unless the function is required).
124 The type of a new function, if one is generated at this point, is
125 constructed as follows:
127 \/ a1 ... \/ an . b1 -> ... -> bn -> t
129 where a1...an are the free type variables in the expression, b1...bn
130 are the types of the free variables in the expression, and t is the
131 type of the expression itself.
135 > -- Collect the value/type arguments for the function
137 > val_args = filter isArgId fvs
138 > ty_args = freeTyVars e
140 > -- Now to make up the type...
141 > base_type = coreExprType core_e
142 > fun_type = glueTyArgs (map idType val_args) base_type
143 > (_, type_of_f) = quantifyTy ty_args fun_type
146 > newDefId type_of_f `thenUs` \f' ->
148 > f = replaceIdInfo f'
149 > (addInfo (getIdInfo f') DoDeforest)
151 > loop ((f,e,val_args,ty_args):ls) e1
152 > `thenUs` \res@(ls',bs,bls,e') ->
154 Key: ls = loops, bs = bindings, bls = back loops, e = expression.
156 If we are in a back-loop (i.e. we found a label somewhere below which
157 this expression is a renaming of), then just insert the expression
160 Comment the next section out to disable back-loops.
162 (NB. I've seen this panic too - investigate?)
164 > let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in
165 > if not (null back_loops){- && not (f `elem` ls')-} then
166 > --if length back_loops > 1 then panic "barf!" else
167 > d2c (head back_loops) `thenUs` \core_e ->
168 > trace ("Back Loop:\n" ++
169 > ppShow 80 (ppr PprDebug core_e)) $
171 If we find a back-loop that also occurs where we would normally make a
174 > if f `elem` ls' then
175 > d2c e' `thenUs` \core_e' ->
176 > trace ("In Forward Loop " ++
177 > ppShow 80 (ppr PprDebug f) ++ "\n" ++
178 > ppShow 80 (ppr PprDebug core_e')) $
179 > if f `notElem` (freeVars (head back_loops)) then
180 > returnUs (ls', bs, bls, head back_loops)
185 > returnUs (ls', bs, bls, head back_loops)
188 If we are in a forward-loop (i.e. we found a label somewhere below
189 which is a renaming of this one), then make a new function definition.
191 > if f `elem` ls' then
193 > rebindExpr (mkLam ty_args val_args e')
197 > (f,filter deforestable (freeVars e'),e,rhs) : bs,
199 > mkLoopFunApp val_args ty_args f)
201 otherwise, forget about it
205 This is a loop, just make a call to the function which we
206 will create on the way back up the tree.
208 (NB: it appears that sometimes we do get more than one loop matching,
211 > ((f,val_args,ty_args,r):_) ->
214 > ([f], -- found a loop, propagate it back
216 > [], -- no back loops
217 > mkLoopFunApp (applyRenaming r val_args) ty_args f)
219 > ) `thenUs` \res@(ls',bs,bls,e') ->
221 If this expression reoccurs, record the binding and replace the cycle
222 with a call to the new function. We also rebind all the free
223 variables in the new function to avoid name clashes later.
226 > findBackLoops (g,r) bls
227 > | consistent r' = subst s e' `thenUs` \e' ->
228 > returnUs ((g,e') : bls)
229 > | otherwise = returnUs bls
232 > s = map (\(x,y) -> (x, Var (DefArgVar y))) (nub r')
235 We just want the first one (ie. furthest up the tree), so reverse the
236 list of inconsistent renamings.
238 > foldrSUs findBackLoops [] (reverse inconsistent_renamings)
239 > `thenUs` \back_loops ->
241 Comment out the next block to disable back-loops. ToDo: trace all of them.
243 > if not (null back_loops) then
244 > d2c e' `thenUs` \core_e ->
245 > trace ("Floating back loop:\n"
246 > ++ ppShow 80 (ppr PprDebug core_e))
247 > returnUs (ls', bs, back_loops ++ bls, e')
251 > loop ls e@(Var (DefArgVar v))
255 > loop ls (Con c ts es)
256 > = mapLbl (loopAtom ls) es `thenLbl` \es ->
257 > returnLbl (Con c ts es)
258 > loop ls (Prim op ts es)
259 > = mapLbl (loopAtom ls) es `thenLbl` \es ->
260 > returnLbl (Prim op ts es)
262 > = loop ls e `thenLbl` \e ->
263 > returnLbl (Lam vs e)
264 > loop ls (CoTyLam alpha e)
265 > = loop ls e `thenLbl` \e ->
266 > returnLbl (CoTyLam alpha e)
268 > = loop ls e `thenLbl` \e ->
269 > loopAtom ls v `thenLbl` \v ->
270 > returnLbl (App e v)
271 > loop ls (CoTyApp e t)
272 > = loop ls e `thenLbl` \e ->
273 > returnLbl (CoTyApp e t)
274 > loop ls (Case e ps)
275 > = loop ls e `thenLbl` \e ->
276 > loopCaseAlts ls ps `thenLbl` \ps ->
277 > returnLbl (Case e ps)
278 > loop ls (Let (NonRec v e) e')
279 > = loop ls e `thenLbl` \e ->
280 > loop ls e' `thenLbl` \e' ->
281 > returnLbl (Let (NonRec v e) e')
282 > loop ls (Let (Rec bs) e)
283 > = mapLbl loopRecBind bs `thenLbl` \bs ->
284 > loop ls e `thenLbl` \e ->
285 > returnLbl (Let (Rec bs) e)
289 > = loop ls e `thenLbl` \e ->
292 > = defPanic "Cyclic" "loop" e
294 > loopAtom ls (VarArg (DefArgExpr e))
295 > = loop ls e `thenLbl` \e ->
296 > returnLbl (VarArg (DefArgExpr e))
297 > loopAtom ls (VarArg e@(DefArgVar v))
298 > = defPanic "Cyclic" "loopAtom" (Var e)
299 > loopAtom ls (VarArg e@(Label _ _))
300 > = defPanic "Cyclic" "loopAtom" (Var e)
301 > loopAtom ls e@(LitArg l)
304 > loopCaseAlts ls (AlgAlts as def) =
305 > mapLbl loopAlgAlt as `thenLbl` \as ->
306 > loopDefault ls def `thenLbl` \def ->
307 > returnLbl (AlgAlts as def)
309 > loopAlgAlt (c, vs, e) =
310 > loop ls e `thenLbl` \e ->
311 > returnLbl (c, vs, e)
313 > loopCaseAlts ls (PrimAlts as def) =
314 > mapLbl loopPrimAlt as `thenLbl` \as ->
315 > loopDefault ls def `thenLbl` \def ->
316 > returnLbl (PrimAlts as def)
318 > loopPrimAlt (l, e) =
319 > loop ls e `thenLbl` \e ->
322 > loopDefault ls NoDefault =
323 > returnLbl NoDefault
324 > loopDefault ls (BindDefault v e) =
325 > loop ls e `thenLbl` \e ->
326 > returnLbl (BindDefault v e)
329 > mkVar v = VarArg (DefArgExpr (Var (DefArgVar v)))
331 -----------------------------------------------------------------------------
332 The next function is applied to all deforestable functions which are
333 placed in the environment. Given a list of free variables in the
334 recursive set of which the function is a member, this funciton
335 abstracts those variables, generates a new Id with the new type, and
336 returns a substitution element which can be applied to all other
337 expressions and function right hand sides that call this function.
339 (freeVars e) \subseteq (freeVars l)
341 > fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)])
342 > fixupFreeVars total_fvs id e =
345 > _ -> let new_type =
346 > glueTyArgs (map idType fvs)
349 > updateIdType id new_type
352 > t = foldl App (Var (DefArgVar new_id))
355 > trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
356 > ((new_id, mkValLam fvs e), [(id,t)])
359 > Lam bvs e -> filter (`notElem` bvs) total_fvs
364 > applyRenaming :: [(Id,Id)] -> [Id] -> [Id]
365 > applyRenaming r ids = map rename ids
367 > rename x = case [ y | (x',y) <- r, x' `eqId` x ] of
368 > [] -> panic "Cyclic(rename): no match in rename"
371 > mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
372 > mkLoopFunApp val_args ty_args f =
374 > (foldl CoTyApp (Var (DefArgVar f))
375 > (mkTyVarTys ty_args))
376 > (map mkVar val_args)
378 -----------------------------------------------------------------------------
379 Removing duplicates from a list of definitions.
381 > removeDuplicateDefinitions
382 > :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs))
383 > -> UniqSM [(Id,DefExpr)]
385 > removeDuplicateDefinitions defs =
386 > foldrSUs rem ([],[]) defs `thenUs` \(newdefs,s) ->
387 > mapUs (\(l,(f,e)) -> subst s e `thenUs` \e ->
388 > returnUs (f, e)) newdefs
391 > rem d@(l,(f,e)) (defs,s) =
392 > findDup l defs `thenUs` \maybe ->
394 > Nothing -> returnUs (d:defs,s)
395 > Just g -> returnUs (defs, (f,(Var.DefArgVar) g):s)
397 We insist that labels rename in both directions, is this necessary?
399 > findDup l [] = returnUs Nothing
400 > findDup l ((l',(f,e)):defs) =
401 > renameExprs l l' `thenUs` \r ->
403 > IsRenaming _ -> renameExprs l' l `thenUs` \r ->
405 > IsRenaming r -> returnUs (Just f)
406 > _ -> findDup l defs
407 > _ -> findDup l defs