2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[Cyclic]{Knot tying}
6 >#include "HsVersions.h"
9 > mkLoops, fixupFreeVars
15 > import Def2Core ( d2c, defPanic )
20 > import AbsUniType ( glueTyArgs, quantifyTy, mkForallTy, mkTyVarTy,
23 > import Digraph ( dfs )
24 > import Id ( getIdUniType, toplevelishId, updateIdType,
25 > getIdInfo, replaceIdInfo, eqId, Id
28 > import Maybes ( Maybe(..) )
34 -----------------------------------------------------------------------------
35 A more efficient representation for lists that are extended multiple
36 times, but only examined once.
38 > type FList a = [a] -> [a]
41 > cons x xs = \ys -> x:(xs ys)
45 -----------------------------------------------------------------------------
46 Monad for the knot-tier.
48 > type Lbl a = SUniqSM (
49 > [(Id)], -- loops used
50 > [(Id,DefExpr,[Id],DefExpr)], -- bindings floating upwards
51 > [(Id,DefExpr)], -- back loops
52 > a) -- computation result
54 > thenLbl :: Lbl a -> (a -> Lbl b) -> Lbl b
56 > = a `thenSUs` \(ls, bs, bls, a) ->
57 > k a `thenSUs` \(ls',bs',bls', b) ->
58 > returnSUs (ls ++ ls', bs ++ bs', bls ++ bls', b)
60 > returnLbl :: a -> Lbl a
61 > returnLbl a = returnSUs ([],[],[],a)
63 > mapLbl :: (a -> Lbl b) -> [a] -> Lbl [b]
64 > mapLbl f [] = returnLbl []
66 > = f x `thenLbl` \x ->
67 > mapLbl f xs `thenLbl` \xs ->
70 -----------------------------------------------------------------------------
72 This is terribly inefficient.
74 > mkLoops :: DefExpr -> SUniqSM ([(Id,DefExpr)],DefExpr)
78 > loop [] e `thenSUs` \(ls,bs,bls,e) ->
80 Throw away all the extracted bindings that can't be reached. These
81 can occur as the result of some forward loops being short-circuited by
82 back-loops. We find out which bindings can be reached by a
83 depth-first search of the call graph starting with the free variables
84 of the expression being returned.
87 > loops_out = filter deforestable (freeVars e)
88 > (_,reachable) = dfs (==) r ([],[]) loops_out
92 > lookup f ((g,out,_):xs) | f == g = out
93 > | otherwise = lookup f xs
95 > isReachable (f,_,_) = f `elem` reachable
97 > returnSUs (map (\(f,_,e) -> (f,e)) (filter isReachable bs),e)
100 > loop :: [(Id,DefExpr,[Id],[TyVar])] -> DefExpr -> Lbl DefExpr
102 > loop ls (CoVar (Label e e1))
104 > d2c e `thenSUs` \core_e ->
105 >-- trace ("loop:\n" ++ ppShow 80 (ppr PprDebug core_e)) $
107 > mapSUs (\(f,e',val_args,ty_args) ->
108 > renameExprs e' e `thenSUs` \r ->
109 > returnSUs (f,val_args,ty_args,r)) ls `thenSUs` \results ->
112 > [ (f,val_args,ty_args,r) |
113 > (f,val_args,ty_args,IsRenaming r) <- results ]
114 > inconsistent_renamings =
116 > (f,val_args,ty_args,InconsistentRenaming r)
123 Ok, there are no loops (i.e. this expression hasn't occurred before).
124 Prepare for a possible re-occurrence of *this* expression, by making
125 up a new function name and type (laziness ensures that this isn't
126 actually done unless the function is required).
128 The type of a new function, if one is generated at this point, is
129 constructed as follows:
131 \/ a1 ... \/ an . b1 -> ... -> bn -> t
133 where a1...an are the free type variables in the expression, b1...bn
134 are the types of the free variables in the expression, and t is the
135 type of the expression itself.
139 > -- Collect the value/type arguments for the function
141 > val_args = filter isArgId fvs
142 > ty_args = freeTyVars e
144 > -- Now to make up the type...
145 > base_type = typeOfCoreExpr core_e
146 > fun_type = glueTyArgs (map getIdUniType val_args) base_type
147 > (_, type_of_f) = quantifyTy ty_args fun_type
150 > newDefId type_of_f `thenSUs` \f' ->
152 > f = replaceIdInfo f'
153 > (addInfo (getIdInfo f') DoDeforest)
155 > loop ((f,e,val_args,ty_args):ls) e1
156 > `thenSUs` \res@(ls',bs,bls,e') ->
158 Key: ls = loops, bs = bindings, bls = back loops, e = expression.
160 If we are in a back-loop (i.e. we found a label somewhere below which
161 this expression is a renaming of), then just insert the expression
164 Comment the next section out to disable back-loops.
166 (NB. I've seen this panic too - investigate?)
168 > let back_loops = reverse [ e | (f',e) <- bls, f' == f ] in
169 > if not (null back_loops){- && not (f `elem` ls')-} then
170 > --if length back_loops > 1 then panic "barf!" else
171 > d2c (head back_loops) `thenSUs` \core_e ->
172 > trace ("Back Loop:\n" ++
173 > ppShow 80 (ppr PprDebug core_e)) $
175 If we find a back-loop that also occurs where we would normally make a
178 > if f `elem` ls' then
179 > d2c e' `thenSUs` \core_e' ->
180 > trace ("In Forward Loop " ++
181 > ppShow 80 (ppr PprDebug f) ++ "\n" ++
182 > ppShow 80 (ppr PprDebug core_e')) $
183 > if f `notElem` (freeVars (head back_loops)) then
184 > returnSUs (ls', bs, bls, head back_loops)
189 > returnSUs (ls', bs, bls, head back_loops)
192 If we are in a forward-loop (i.e. we found a label somewhere below
193 which is a renaming of this one), then make a new function definition.
195 > if f `elem` ls' then
197 > rebindExpr (mkCoTyLam ty_args (mkCoLam val_args e'))
201 > (f,filter deforestable (freeVars e'),e,rhs) : bs,
203 > mkLoopFunApp val_args ty_args f)
205 otherwise, forget about it
209 This is a loop, just make a call to the function which we
210 will create on the way back up the tree.
212 (NB: it appears that sometimes we do get more than one loop matching,
215 > ((f,val_args,ty_args,r):_) ->
218 > ([f], -- found a loop, propagate it back
220 > [], -- no back loops
221 > mkLoopFunApp (applyRenaming r val_args) ty_args f)
223 > ) `thenSUs` \res@(ls',bs,bls,e') ->
225 If this expression reoccurs, record the binding and replace the cycle
226 with a call to the new function. We also rebind all the free
227 variables in the new function to avoid name clashes later.
230 > findBackLoops (g,r) bls
231 > | consistent r' = subst s e' `thenSUs` \e' ->
232 > returnSUs ((g,e') : bls)
233 > | otherwise = returnSUs bls
236 > s = map (\(x,y) -> (x, CoVar (DefArgVar y))) (nub r')
239 We just want the first one (ie. furthest up the tree), so reverse the
240 list of inconsistent renamings.
242 > foldrSUs findBackLoops [] (reverse inconsistent_renamings)
243 > `thenSUs` \back_loops ->
245 Comment out the next block to disable back-loops. ToDo: trace all of them.
247 > if not (null back_loops) then
248 > d2c e' `thenSUs` \core_e ->
249 > trace ("Floating back loop:\n"
250 > ++ ppShow 80 (ppr PprDebug core_e))
251 > returnSUs (ls', bs, back_loops ++ bls, e')
255 > loop ls e@(CoVar (DefArgVar v))
257 > loop ls e@(CoLit l)
259 > loop ls (CoCon c ts es)
260 > = mapLbl (loopAtom ls) es `thenLbl` \es ->
261 > returnLbl (CoCon c ts es)
262 > loop ls (CoPrim op ts es)
263 > = mapLbl (loopAtom ls) es `thenLbl` \es ->
264 > returnLbl (CoPrim op ts es)
265 > loop ls (CoLam vs e)
266 > = loop ls e `thenLbl` \e ->
267 > returnLbl (CoLam vs e)
268 > loop ls (CoTyLam alpha e)
269 > = loop ls e `thenLbl` \e ->
270 > returnLbl (CoTyLam alpha e)
271 > loop ls (CoApp e v)
272 > = loop ls e `thenLbl` \e ->
273 > loopAtom ls v `thenLbl` \v ->
274 > returnLbl (CoApp e v)
275 > loop ls (CoTyApp e t)
276 > = loop ls e `thenLbl` \e ->
277 > returnLbl (CoTyApp e t)
278 > loop ls (CoCase e ps)
279 > = loop ls e `thenLbl` \e ->
280 > loopCaseAlts ls ps `thenLbl` \ps ->
281 > returnLbl (CoCase e ps)
282 > loop ls (CoLet (CoNonRec v e) e')
283 > = loop ls e `thenLbl` \e ->
284 > loop ls e' `thenLbl` \e' ->
285 > returnLbl (CoLet (CoNonRec v e) e')
286 > loop ls (CoLet (CoRec bs) e)
287 > = mapLbl loopRecBind bs `thenLbl` \bs ->
288 > loop ls e `thenLbl` \e ->
289 > returnLbl (CoLet (CoRec bs) e)
293 > = loop ls e `thenLbl` \e ->
296 > = defPanic "Cyclic" "loop" e
298 > loopAtom ls (CoVarAtom (DefArgExpr e))
299 > = loop ls e `thenLbl` \e ->
300 > returnLbl (CoVarAtom (DefArgExpr e))
301 > loopAtom ls (CoVarAtom e@(DefArgVar v))
302 > = defPanic "Cyclic" "loopAtom" (CoVar e)
303 > loopAtom ls (CoVarAtom e@(Label _ _))
304 > = defPanic "Cyclic" "loopAtom" (CoVar e)
305 > loopAtom ls e@(CoLitAtom l)
308 > loopCaseAlts ls (CoAlgAlts as def) =
309 > mapLbl loopAlgAlt as `thenLbl` \as ->
310 > loopDefault ls def `thenLbl` \def ->
311 > returnLbl (CoAlgAlts as def)
313 > loopAlgAlt (c, vs, e) =
314 > loop ls e `thenLbl` \e ->
315 > returnLbl (c, vs, e)
317 > loopCaseAlts ls (CoPrimAlts as def) =
318 > mapLbl loopPrimAlt as `thenLbl` \as ->
319 > loopDefault ls def `thenLbl` \def ->
320 > returnLbl (CoPrimAlts as def)
322 > loopPrimAlt (l, e) =
323 > loop ls e `thenLbl` \e ->
326 > loopDefault ls CoNoDefault =
327 > returnLbl CoNoDefault
328 > loopDefault ls (CoBindDefault v e) =
329 > loop ls e `thenLbl` \e ->
330 > returnLbl (CoBindDefault v e)
333 > mkVar v = CoVarAtom (DefArgExpr (CoVar (DefArgVar v)))
335 -----------------------------------------------------------------------------
336 The next function is applied to all deforestable functions which are
337 placed in the environment. Given a list of free variables in the
338 recursive set of which the function is a member, this funciton
339 abstracts those variables, generates a new Id with the new type, and
340 returns a substitution element which can be applied to all other
341 expressions and function right hand sides that call this function.
343 (freeVars e) \subseteq (freeVars l)
345 > fixupFreeVars :: [Id] -> Id -> DefExpr -> ((Id,DefExpr),[(Id,DefExpr)])
346 > fixupFreeVars total_fvs id e =
349 > _ -> let new_type =
350 > glueTyArgs (map getIdUniType fvs)
353 > updateIdType id new_type
356 > t = foldl CoApp (CoVar (DefArgVar new_id))
359 > trace ("adding " ++ show (length fvs) ++ " args to " ++ ppShow 80 (ppr PprDebug id)) $
360 > ((new_id, mkCoLam fvs e), [(id,t)])
363 > CoLam bvs e -> filter (`notElem` bvs) total_fvs
368 > applyRenaming :: [(Id,Id)] -> [Id] -> [Id]
369 > applyRenaming r ids = map rename ids
371 > rename x = case [ y | (x',y) <- r, x' `eqId` x ] of
372 > [] -> panic "Cyclic(rename): no match in rename"
375 > mkLoopFunApp :: [Id] -> [TyVar] -> Id -> DefExpr
376 > mkLoopFunApp val_args ty_args f =
378 > (foldl CoTyApp (CoVar (DefArgVar f))
379 > (map mkTyVarTy ty_args))
380 > (map mkVar val_args)
382 -----------------------------------------------------------------------------
383 Removing duplicates from a list of definitions.
385 > removeDuplicateDefinitions
386 > :: [(DefExpr,(Id,DefExpr))] -- (label,(id,rhs))
387 > -> SUniqSM [(Id,DefExpr)]
389 > removeDuplicateDefinitions defs =
390 > foldrSUs rem ([],[]) defs `thenSUs` \(newdefs,s) ->
391 > mapSUs (\(l,(f,e)) -> subst s e `thenSUs` \e ->
392 > returnSUs (f, e)) newdefs
395 > rem d@(l,(f,e)) (defs,s) =
396 > findDup l defs `thenSUs` \maybe ->
398 > Nothing -> returnSUs (d:defs,s)
399 > Just g -> returnSUs (defs, (f,(CoVar.DefArgVar) g):s)
401 We insist that labels rename in both directions, is this necessary?
403 > findDup l [] = returnSUs Nothing
404 > findDup l ((l',(f,e)):defs) =
405 > renameExprs l l' `thenSUs` \r ->
407 > IsRenaming _ -> renameExprs l' l `thenSUs` \r ->
409 > IsRenaming r -> returnSUs (Just f)
410 > _ -> findDup l defs
411 > _ -> findDup l defs