2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DefUtils]{Miscellaneous Utility functions}
6 >#include "HsVersions.h"
9 > strip, stripAtom, stripCaseAlts, freeVars, renameExprs, rebindExpr,
10 > atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
11 > mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
17 > import Def2Core -- tmp, for traces
23 > import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
24 > tyVarsOfType, TyVar, SYN_IE(SigmaType)
26 > import Literal ( Literal ) -- for Eq Literal
28 > import Id ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
29 > getIdInfo, toplevelishId, idType, Id )
33 > import PrimOp ( PrimOp ) -- for Eq PrimOp
35 > import SrcLoc ( noSrcLoc )
38 -----------------------------------------------------------------------------
41 Implementation of the strip function. Strip is the identity on
42 expressions (recursing into subterms), but replaces each label with
43 its left hand side. The result is a term with no labels.
45 > strip :: DefExpr -> DefExpr
47 > strip e' = case e' of
48 > Var (DefArgExpr e) -> panic "DefUtils(strip): Var (DefExpr _)"
49 > Var (Label l e) -> l
50 > Var (DefArgVar v) -> e'
52 > Con c ts es -> Con c ts (map stripAtom es)
53 > Prim op ts es -> Prim op ts (map stripAtom es)
54 > Lam vs e -> Lam vs (strip e)
55 > CoTyLam alpha e -> CoTyLam alpha (strip e)
56 > App e v -> App (strip e) (stripAtom v)
57 > CoTyApp e t -> CoTyApp (strip e) t
58 > Case e ps -> Case (strip e) (stripCaseAlts ps)
59 > Let (NonRec v e) e' -> Let (NonRec v (strip e)) (strip e')
61 > Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e)
62 > SCC l e -> SCC l (strip e)
63 > Coerce _ _ _ -> panic "DefUtils:strip:Coerce"
65 > stripAtom :: DefAtom -> DefAtom
66 > stripAtom (VarArg v) = VarArg (stripArg v)
67 > stripAtom (LitArg l) = LitArg l -- XXX
69 > stripArg :: DefBindee -> DefBindee
70 > stripArg (DefArgExpr e) = DefArgExpr (strip e)
71 > stripArg (Label l e) = panic "DefUtils(stripArg): Label _ _"
72 > stripArg (DefArgVar v) = panic "DefUtils(stripArg): DefArgVar _ _"
74 > stripCaseAlts (AlgAlts as def)
75 > = AlgAlts (map stripAlgAlt as) (stripDefault def)
76 > stripCaseAlts (PrimAlts as def)
77 > = PrimAlts (map stripPrimAlt as) (stripDefault def)
79 > stripAlgAlt (c, vs, e) = (c, vs, strip e)
80 > stripPrimAlt (l, e) = (l, strip e)
82 > stripDefault NoDefault = NoDefault
83 > stripDefault (BindDefault v e) = BindDefault v (strip e)
85 -----------------------------------------------------------------------------
86 \subsection{Free Variables}
88 Find the free variables of an expression. With labels, we descend
89 into the left side since this is the only sensible thing to do.
90 Strictly speaking, for a term (Label l e), freeVars l == freeVars e,
91 but l is guranteed to be finite so we choose that one.
93 > freeVars :: DefExpr -> [Id]
94 > freeVars e = free e []
96 > free e fvs = case e of
97 > Var (DefArgExpr e) ->
98 > panic "DefUtils(free): Var (DefExpr _)"
99 > Var (Label l e) -> free l fvs
101 > | v `is_elem` fvs -> fvs
102 > | otherwise -> v : fvs
103 > where { is_elem = isIn "freeVars(deforest)" }
105 > Con c ts es -> foldr freeAtom fvs es
106 > Prim op ts es -> foldr freeAtom fvs es
107 > Lam vs e -> free' vs (free e fvs)
108 > CoTyLam alpha e -> free e fvs
109 > App e v -> free e (freeAtom v fvs)
110 > CoTyApp e t -> free e fvs
111 > Case e ps -> free e (freeCaseAlts ps fvs)
112 > Let (NonRec v e) e' -> free e (free' [v] (free e' fvs))
113 > Let (Rec bs) e -> free' vs (foldr free (free e fvs) es)
114 > where (vs,es) = unzip bs
115 > SCC l e -> free e fvs
116 > Coerce _ _ _ -> panic "DefUtils.freeVars:Coerce"
118 > free' :: [Id] -> [Id] -> [Id]
119 > free' vs fvs = filter (\x -> notElem x vs) fvs
121 > freeAtom (VarArg (DefArgExpr e)) fvs = free e fvs
122 > freeAtom (VarArg (Label l e)) fvs
123 > = panic "DefUtils(free): VarArg (Label _ _)"
124 > freeAtom (VarArg (DefArgVar v)) fvs
125 > = panic "DefUtils(free): VarArg (DefArgVar _ _)"
126 > freeAtom (LitArg l) fvs = fvs
128 > freeCaseAlts (AlgAlts as def) fvs
129 > = foldr freeAlgAlt (freeDefault def fvs) as
130 > freeCaseAlts (PrimAlts as def) fvs
131 > = foldr freePrimAlt (freeDefault def fvs) as
133 > freeAlgAlt (c, vs, e) fvs = free' vs (free e fvs)
134 > freePrimAlt (l, e) fvs = free e fvs
136 > freeDefault NoDefault fvs = fvs
137 > freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
139 -----------------------------------------------------------------------------
140 \subsection{Free Type Variables}
142 > freeTyVars :: DefExpr -> [TyVar]
143 > freeTyVars e = free e []
145 > free e tvs = case e of
146 > Var (DefArgExpr e) ->
147 > panic "DefUtils(freeVars): Var (DefExpr _)"
148 > Var (Label l e) -> free l tvs
149 > Var (DefArgVar id) -> freeId id tvs
151 > Con c ts es -> foldr freeTy (foldr freeAtom tvs es) ts
152 > Prim op ts es -> foldr freeTy (foldr freeAtom tvs es) ts
153 > Lam vs e -> foldr freeId (free e tvs) vs
154 > CoTyLam alpha e -> filter (/= alpha) (free e tvs)
155 > App e v -> free e (freeAtom v tvs)
156 > CoTyApp e t -> free e (freeTy t tvs)
157 > Case e ps -> free e (freeCaseAlts ps tvs)
158 > Let (NonRec v e) e' -> free e (freeId v (free e' tvs))
159 > Let (Rec bs) e -> foldr freeBind (free e tvs) bs
160 > SCC l e -> free e tvs
161 > Coerce _ _ _ -> panic "DefUtils.freeTyVars:Coerce"
163 > freeId id tvs = tyVarsOfType (idType id) `union` tvs
164 > freeTy t tvs = tyVarsOfType t `union` tvs
165 > freeBind (v,e) tvs = freeId v (free e tvs)
167 > freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs
168 > freeAtom (VarArg (Label l e)) tvs
169 > = panic "DefUtils(freeVars): VarArg (Label _ _)"
170 > freeAtom (VarArg (DefArgVar v)) tvs
171 > = panic "DefUtils(freeVars): VarArg (DefArgVar _ _)"
172 > freeAtom (LitArg l) tvs = tvs -- XXX
174 > freeCaseAlts (AlgAlts as def) tvs
175 > = foldr freeAlgAlt (freeDefault def tvs) as
176 > freeCaseAlts (PrimAlts as def) tvs
177 > = foldr freePrimAlt (freeDefault def tvs) as
179 > freeAlgAlt (c, vs, e) tvs = foldr freeId (free e tvs) vs
180 > freePrimAlt (l, e) tvs = free e tvs
182 > freeDefault NoDefault tvs = tvs
183 > freeDefault (BindDefault v e) tvs = freeId v (free e tvs)
185 -----------------------------------------------------------------------------
186 \subsection{Rebinding variables in an expression}
188 Here is the code that renames all the bound variables in an expression
189 with new uniques. Free variables are left unchanged.
191 > rebindExpr :: DefExpr -> UniqSM DefExpr
192 > rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
194 > uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
197 > Var (DefArgVar v) ->
198 > returnUs (Var (DefArgVar (lookup v p)))
201 > uniqueExpr p t l `thenUs` \l ->
202 > uniqueExpr p t e `thenUs` \e ->
203 > returnUs (mkLabel l e)
205 > Var (DefArgExpr _) ->
206 > panic "DefUtils(uniqueExpr): Var(DefArgExpr _)"
212 > mapUs (uniqueAtom p t) es `thenUs` \es ->
213 > returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
216 > mapUs (uniqueAtom p t) es `thenUs` \es ->
217 > returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
220 > mapUs (newVar t) vs `thenUs` \vs' ->
221 > uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e ->
222 > returnUs (Lam vs' e)
225 > getUnique `thenUs` \u ->
226 > let v' = cloneTyVar v u
227 > t' = addOneToTyVarEnv t v (mkTyVarTy v') in
228 > uniqueExpr p t' e `thenUs` \e ->
229 > returnUs (CoTyLam v' e)
232 > uniqueExpr p t e `thenUs` \e ->
233 > uniqueAtom p t v `thenUs` \v ->
237 > uniqueExpr p t e `thenUs` \e ->
238 > returnUs (CoTyApp e (applyTypeEnvToTy t ty))
241 > uniqueExpr p t e `thenUs` \e ->
242 > uniqueAlts alts `thenUs` \alts ->
243 > returnUs (Case e alts)
245 > uniqueAlts (AlgAlts as d) =
246 > mapUs uniqueAlgAlt as `thenUs` \as ->
247 > uniqueDefault d `thenUs` \d ->
248 > returnUs (AlgAlts as d)
249 > uniqueAlts (PrimAlts as d) =
250 > mapUs uniquePrimAlt as `thenUs` \as ->
251 > uniqueDefault d `thenUs` \d ->
252 > returnUs (PrimAlts as d)
254 > uniqueAlgAlt (c, vs, e) =
255 > mapUs (newVar t) vs `thenUs` \vs' ->
256 > uniqueExpr (growIdEnvList p (zip vs vs')) t e
258 > returnUs (c, vs', e)
259 > uniquePrimAlt (l, e) =
260 > uniqueExpr p t e `thenUs` \e ->
263 > uniqueDefault NoDefault = returnUs NoDefault
264 > uniqueDefault (BindDefault v e) =
265 > newVar t v `thenUs` \v' ->
266 > uniqueExpr (addOneToIdEnv p v v') t e `thenUs` \e ->
267 > returnUs (BindDefault v' e)
269 > Let (NonRec v e) e' ->
270 > uniqueExpr p t e `thenUs` \e ->
271 > newVar t v `thenUs` \v' ->
272 > uniqueExpr (addOneToIdEnv p v v') t e' `thenUs` \e' ->
273 > returnUs (Let (NonRec v' e) e')
276 > let (vs,es) = unzip ds in
277 > mapUs (newVar t) vs `thenUs` \vs' ->
278 > let p' = growIdEnvList p (zip vs vs') in
279 > mapUs (uniqueExpr p' t) es `thenUs` \es ->
280 > uniqueExpr p' t e `thenUs` \e ->
281 > returnUs (Let (Rec (zip vs' es)) e)
284 > uniqueExpr p t e `thenUs` \e ->
287 > Coerce _ _ _ -> panic "DefUtils.uniqueExpr:Coerce"
289 > uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom
290 > uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX
291 > uniqueAtom p t (VarArg v) =
292 > uniqueArg p t v `thenUs` \v ->
293 > returnUs (VarArg v)
295 > uniqueArg p t (DefArgVar v) =
296 > panic "DefUtils(uniqueArg): DefArgVar _ _"
297 > uniqueArg p t (DefArgExpr e) =
298 > uniqueExpr p t e `thenUs` \e ->
299 > returnUs (DefArgExpr e)
300 > uniqueArg p t (Label l e) =
301 > panic "DefUtils(uniqueArg): Label _ _"
303 We shouldn't need to apply the type environment to free variables,
304 since their types can only contain type variables that are free in the
305 expression as a whole (?)
307 > lookup :: Id -> IdEnv Id -> Id
309 > case lookupIdEnv p id of
311 > Just new_id -> new_id
313 > newVar :: TypeEnv -> Id -> UniqSM Id
315 > getUnique `thenUs` \u ->
316 > returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
318 -----------------------------------------------------------------------------
319 \subsection{Detecting Renamings}
321 The function `renameExprs' takes two expressions and returns True if
322 they are renamings of each other. The variables in the list `fs' are
323 excluded from the renaming process (i.e. if any of these variables
324 are present in one expression, they cannot be renamed in the other
327 We only allow renaming of sysLocal ids - ie. not top-level, imported
328 or otherwise global ids.
332 > | IsRenaming [(Id,Id)]
333 > | InconsistentRenaming [(Id,Id)]
335 > renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
338 > [] -> returnUs NotRenaming
339 > [r] -> if not (consistent r) then
340 > d2c (strip u) `thenUs` \u ->
341 > d2c (strip u') `thenUs` \u' ->
342 > trace ("failed consistency check:\n" ++
343 > show (ppr PprDebug u) ++ "\n" ++
344 > show (ppr PprDebug u'))
345 > (returnUs (InconsistentRenaming r))
347 > trace "Renaming!" (returnUs (IsRenaming r))
348 > _ -> panic "DefUtils(renameExprs)"
350 Check that we have a consistent renaming. A renaming is consistent if
351 each time variable x in expression 1 is renamed, it is renamed to the
354 > consistent :: [(Id,Id)] -> Bool
355 > consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ]
357 > checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
358 > checkConsistency bound free = [ r' | r <- free, r' <- check r ]
360 > check r | they're_consistent = [frees]
363 > (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
364 > (lbound,rbound) = unzip bound
365 > they're_consistent = consistent (bound ++ bounds)
367 Renaming composition operator.
369 > (....) :: [[a]] -> [[a]] -> [[a]]
370 > r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ]
372 The class of identifiers which can be renamed. It is sensible to
373 disallow renamings of deforestable ids, but the top-level ones are a
374 bit iffy. Ideally, we should allow renaming of top-level ids, but the
375 current scheme allows us to leave out the top-level ids from the
376 argument lists of new function definitions. (we still have the
377 shadowed ones to worry about..)
379 Main renaming function. Returns a list of renamings made while
380 comparing the expressions.
382 > ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
384 > -- renaming or identical cases --
387 > -- same variable, no renaming
388 > ren (Var (DefArgVar x)) t@(Var (DefArgVar y))
389 > | x == y = [[(x,y)]]
390 > | isArgId x && isArgId y = [[(x,y)]]
392 > -- if we're doing matching, use the next rule,
393 > -- and delete the second clause in the above rule.
395 > ren (Var (DefArgVar x)) t
396 > | okToRename x && all (not. deforestable) (freeVars t)
400 > ren (Lit l) (Lit l') | l == l'
402 > ren (Con c ts es) (Con c' ts' es') | c == c'
403 > = foldr (....) [[]] (zipWith renAtom es es')
404 > ren (Prim op ts es) (Prim op' ts' es') | op == op'
405 > = foldr (....) [[]] (zipWith renAtom es es')
406 > ren (Lam vs e) (Lam vs' e')
407 > = checkConsistency (zip vs vs') (ren e e')
408 > ren (CoTyLam vs e) (CoTyLam vs' e')
410 > ren (App e v) (App e' v')
411 > = ren e e' .... renAtom v v'
412 > ren (CoTyApp e t) (CoTyApp e' t')
414 > ren (Case e alts) (Case e' alts')
415 > = ren e e' .... renAlts alts alts'
416 > ren (Let (NonRec v a) b) (Let (NonRec v' a') b')
417 > = ren a a' .... (checkConsistency [(v,v')] (ren b b'))
418 > ren (Let (Rec ds) e) (Let (Rec ds') e')
419 > = checkConsistency (zip vs vs')
420 > (ren e e' .... (foldr (....) [[]] (zipWith ren es es')))
421 > where (vs ,es ) = unzip ds
422 > (vs',es') = unzip ds'
426 > ren (Var (Label l e)) e' = ren l e'
427 > ren e (Var (Label l e')) = ren e l
431 > ren (Var (DefArgExpr _)) _
432 > = panic "DefUtils(ren): Var (DefArgExpr _)"
433 > ren _ (Var (DefArgExpr _))
434 > = panic "DefUtils(ren): Var (DefArgExpr _)"
442 > renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
444 > -- XXX shouldn't need the next two
445 > renAtom (LitArg l) (LitArg l') | l == l' = [[]]
446 > renAtom (VarArg (DefArgVar v)) _ =
447 > panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
448 > renAtom _ (VarArg (DefArgVar v)) =
449 > panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
450 > renAtom (VarArg (Label _ _)) _ =
451 > panic "DefUtils(renAtom): VarArg (Label _ _)"
452 > renAtom e (VarArg (Label l e')) =
453 > panic "DefUtils(renAtom): VarArg (Label _ _)"
457 Renamings of case alternatives doesn't allow reordering, but that
458 should be Ok (we don't ever change the ordering anyway).
460 > renAlts (AlgAlts as dflt) (AlgAlts as' dflt')
461 > = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
462 > renAlts (PrimAlts as dflt) (PrimAlts as' dflt')
463 > = foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt'
466 > renAlgAlt (c,vs,e) (c',vs',e') | c == c'
467 > = checkConsistency (zip vs vs') (ren e e')
470 > renPrimAlt (l,e) (l',e') | l == l' = ren e e'
471 > renPrimAlt _ _ = []
473 > renDefault NoDefault NoDefault = [[]]
474 > renDefault (BindDefault v e) (BindDefault v' e')
475 > = checkConsistency [(v,v')] (ren e e')
477 -----------------------------------------------------------------------------
479 > atom2expr :: DefAtom -> DefExpr
480 > atom2expr (VarArg (DefArgExpr e)) = e
481 > atom2expr (VarArg (Label l e)) = mkLabel l e
482 > -- XXX next two should be illegal
483 > atom2expr (LitArg l) = Lit l
484 > atom2expr (VarArg (DefArgVar v)) =
485 > panic "DefUtils(atom2expr): VarArg (DefArgVar _)"
487 > expr2atom = VarArg . DefArgExpr
489 -----------------------------------------------------------------------------
490 Grab a new Id and tag it as coming from the Deforester.
492 > newDefId :: Type -> UniqSM Id
494 > getUnique `thenUs` \u ->
495 > returnUs (mkSysLocal SLIT("def") u t noSrcLoc)
497 > newTmpId :: Type -> UniqSM Id
499 > getUnique `thenUs` \u ->
500 > returnUs (mkSysLocal SLIT("tmp") u t noSrcLoc)
502 -----------------------------------------------------------------------------
503 Check whether an Id was given a `DEFOREST' annotation by the programmer.
505 > deforestable :: Id -> Bool
507 > case getDeforestInfo (getIdInfo id) of
509 > Don'tDeforest -> False
511 -----------------------------------------------------------------------------
512 Filter for free variables to abstract from new functions.
515 > = (not . deforestable) id
516 > && (not . toplevelishId) id
518 -----------------------------------------------------------------------------
520 > foldrSUs f c [] = returnUs c
521 > foldrSUs f c (x:xs)
522 > = foldrSUs f c xs `thenUs` \xs' ->
525 -----------------------------------------------------------------------------
527 > mkDefLetrec [] e = e
528 > mkDefLetrec bs e = Let (Rec bs) e
530 -----------------------------------------------------------------------------
533 > subst :: [(Id,DefExpr)]
537 > subst p e' = sub e'
540 > sub e' = case e' of
541 > Var (DefArgExpr e) -> panic "DefExpr(sub): Var (DefArgExpr _)"
542 > Var (Label l e) -> panic "DefExpr(sub): Var (Label _ _)"
543 > Var (DefArgVar v) ->
544 > case lookupIdEnv p' v of
545 > Just e -> rebindExpr e `thenUs` \e -> returnUs e
546 > Nothing -> returnUs e'
547 > Lit l -> returnUs e'
548 > Con c ts es -> mapUs substAtom es `thenUs` \es ->
549 > returnUs (Con c ts es)
550 > Prim op ts es -> mapUs substAtom es `thenUs` \es ->
551 > returnUs (Prim op ts es)
552 > Lam vs e -> sub e `thenUs` \e ->
553 > returnUs (Lam vs e)
554 > CoTyLam alpha e -> sub e `thenUs` \e ->
555 > returnUs (CoTyLam alpha e)
556 > App e v -> sub e `thenUs` \e ->
557 > substAtom v `thenUs` \v ->
559 > CoTyApp e t -> sub e `thenUs` \e ->
560 > returnUs (CoTyApp e t)
561 > Case e ps -> sub e `thenUs` \e ->
562 > substCaseAlts ps `thenUs` \ps ->
563 > returnUs (Case e ps)
564 > Let (NonRec v e) e'
565 > -> sub e `thenUs` \e ->
566 > sub e' `thenUs` \e' ->
567 > returnUs (Let (NonRec v e) e')
568 > Let (Rec bs) e -> sub e `thenUs` \e ->
569 > mapUs substBind bs `thenUs` \bs ->
570 > returnUs (Let (Rec bs) e)
573 > sub e `thenUs` \e ->
575 > SCC l e -> sub e `thenUs` \e ->
578 > Coerce _ _ _ -> panic "DefUtils.subst:Coerce"
580 > substAtom (VarArg v) =
581 > substArg v `thenUs` \v ->
582 > returnUs (VarArg v)
583 > substAtom (LitArg l) =
584 > returnUs (LitArg l) -- XXX
586 > substArg (DefArgExpr e) =
587 > sub e `thenUs` \e ->
588 > returnUs (DefArgExpr e)
589 > substArg e@(Label _ _) =
590 > panic "DefExpr(substArg): Label _ _"
591 > substArg e@(DefArgVar v) = -- XXX
592 > case lookupIdEnv p' v of
593 > Just e -> rebindExpr e `thenUs` \e ->
594 > returnUs (DefArgExpr e)
595 > Nothing -> returnUs e
597 > substCaseAlts (AlgAlts as def) =
598 > mapUs substAlgAlt as `thenUs` \as ->
599 > substDefault def `thenUs` \def ->
600 > returnUs (AlgAlts as def)
601 > substCaseAlts (PrimAlts as def) =
602 > mapUs substPrimAlt as `thenUs` \as ->
603 > substDefault def `thenUs` \def ->
604 > returnUs (PrimAlts as def)
606 > substAlgAlt (c, vs, e) =
607 > sub e `thenUs` \e ->
608 > returnUs (c, vs, e)
609 > substPrimAlt (l, e) =
610 > sub e `thenUs` \e ->
613 > substDefault NoDefault =
615 > substDefault (BindDefault v e) =
616 > sub e `thenUs` \e ->
617 > returnUs (BindDefault v e)
619 -----------------------------------------------------------------------------
623 > | x `is_elem` ys = union xs ys
624 > | otherwise = x : union xs ys
625 > where { is_elem = isIn "union(deforest)" }