ghc/compiler/deforest/DefUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[DefUtils]{Miscellaneous Utility functions}
   5
   6 >#include "HsVersions.h"
   7
   8 > module DefUtils (
   9 >       strip, stripAtom, stripCaseAlts, freeVars, renameExprs, rebindExpr,
  10 >       atom2expr, newDefId, newTmpId, deforestable, foldrSUs,
  11 >       mkDefLetrec, subst, freeTyVars, union, consistent, RenameResult(..),
  12 >       isArgId
  13 >       )
  14 >       where
  15
  16 > import DefSyn
  17 > import Def2Core       -- tmp, for traces
  18
  19 >#ifdef __HBC__
  20 > import Trace
  21 >#endif
  22
  23 > import Type           ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
  24 >                         tyVarsOfType, TyVar, SigmaType(..)
  25 >                       )
  26 > import Literal        ( Literal )     -- for Eq Literal
  27 > import CoreSyn
  28 > import Id             ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
  29 >                         getIdInfo, toplevelishId, idType, Id )
  30 > import IdInfo
  31 > import Outputable
  32 > import Pretty
  33 > import PrimOp ( PrimOp )      -- for Eq PrimOp
  34 > import UniqSupply
  35 > import SrcLoc         ( mkUnknownSrcLoc )
  36 > import Util
  37
  38 -----------------------------------------------------------------------------
  39 \susbsection{Strip}
  40
  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.
  44
  45 > strip :: DefExpr -> DefExpr
  46
  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'
  51 >       Lit l              -> 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')
  60 >       Let (Rec bs) 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"
  64
  65 > stripAtom :: DefAtom -> DefAtom
  66 > stripAtom (VarArg v) = VarArg (stripArg v)
  67 > stripAtom (LitArg l) = LitArg l       -- XXX
  68
  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 _ _"
  73
  74 > stripCaseAlts (AlgAlts as def)
  75 >       = AlgAlts (map stripAlgAlt as) (stripDefault def)
  76 > stripCaseAlts (PrimAlts as def)
  77 >       = PrimAlts (map stripPrimAlt as) (stripDefault def)
  78
  79 > stripAlgAlt  (c, vs, e) = (c, vs, strip e)
  80 > stripPrimAlt (l, e) = (l, strip e)
  81
  82 > stripDefault NoDefault = NoDefault
  83 > stripDefault (BindDefault v e) = BindDefault v (strip e)
  84
  85 -----------------------------------------------------------------------------
  86 \subsection{Free Variables}
  87
  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.
  92
  93 > freeVars :: DefExpr -> [Id]
  94 > freeVars e = free e []
  95 >   where
  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
 100 >               Var (DefArgVar v)
 101 >                       | v `is_elem` fvs       -> fvs
 102 >                       | otherwise     -> v : fvs
 103 >                 where { is_elem = isIn "freeVars(deforest)" }
 104 >               Lit l              -> fvs
 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"
 117
 118 >       free' :: [Id] -> [Id] -> [Id]
 119 >       free' vs fvs = filter (\x -> notElem x vs) fvs
 120
 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
 127
 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
 132 >
 133 >       freeAlgAlt  (c, vs, e) fvs = free' vs (free e fvs)
 134 >       freePrimAlt (l, e) fvs = free e fvs
 135
 136 >       freeDefault NoDefault fvs = fvs
 137 >       freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
 138
 139 -----------------------------------------------------------------------------
 140 \subsection{Free Type Variables}
 141
 142 > freeTyVars :: DefExpr -> [TyVar]
 143 > freeTyVars e = free e []
 144 >   where
 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
 150 >               Lit l                 -> 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"
 162 >
 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)
 166
 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
 173
 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
 178
 179 >       freeAlgAlt  (c, vs, e) tvs = foldr freeId (free e tvs) vs
 180 >       freePrimAlt (l, e) tvs = free e tvs
 181
 182 >       freeDefault NoDefault tvs = tvs
 183 >       freeDefault (BindDefault v e) tvs = freeId v (free e tvs)
 184
 185 -----------------------------------------------------------------------------
 186 \subsection{Rebinding variables in an expression}
 187
 188 Here is the code that renames all the bound variables in an expression
 189 with new uniques.  Free variables are left unchanged.
 190
 191 > rebindExpr :: DefExpr -> UniqSM DefExpr
 192 > rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
 193
 194 > uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
 195 > uniqueExpr p t e =
 196 >   case e of
 197 >       Var (DefArgVar v) ->
 198 >               returnUs (Var (DefArgVar (lookup v p)))
 199 >
 200 >       Var (Label l e) ->
 201 >               uniqueExpr p t l                `thenUs` \l ->
 202 >               uniqueExpr p t e                `thenUs` \e ->
 203 >               returnUs (mkLabel l e)
 204 >
 205 >       Var (DefArgExpr _) ->
 206 >               panic "DefUtils(uniqueExpr): Var(DefArgExpr _)"
 207 >
 208 >       Lit l ->
 209 >               returnUs e
 210 >
 211 >       Con c ts es ->
 212 >               mapUs (uniqueAtom p t) es       `thenUs` \es ->
 213 >               returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
 214 >
 215 >       Prim op ts es ->
 216 >               mapUs (uniqueAtom p t) es        `thenUs` \es ->
 217 >               returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
 218 >
 219 >       Lam vs e ->
 220 >               mapUs (newVar t) vs             `thenUs` \vs' ->
 221 >               uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e ->
 222 >               returnUs (Lam vs' e)
 223 >
 224 >       CoTyLam v 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)
 230 >
 231 >       App e v ->
 232 >               uniqueExpr p t e                `thenUs` \e ->
 233 >               uniqueAtom p t v                `thenUs` \v ->
 234 >               returnUs (App e v)
 235 >
 236 >       CoTyApp e ty ->
 237 >               uniqueExpr p t e                `thenUs` \e ->
 238 >               returnUs (CoTyApp e (applyTypeEnvToTy t ty))
 239 >
 240 >       Case e alts ->
 241 >               uniqueExpr p t e                `thenUs` \e ->
 242 >               uniqueAlts alts                 `thenUs` \alts ->
 243 >               returnUs (Case e alts)
 244 >            where
 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)
 253 >
 254 >               uniqueAlgAlt (c, vs, e) =
 255 >                       mapUs (newVar t) vs     `thenUs` \vs' ->
 256 >                       uniqueExpr (growIdEnvList p (zip vs vs')) t e
 257 >                                               `thenUs` \e ->
 258 >                       returnUs (c, vs', e)
 259 >               uniquePrimAlt (l, e) =
 260 >                       uniqueExpr p t e        `thenUs` \e ->
 261 >                       returnUs (l, e)
 262 >
 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)
 268 >
 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')
 274 >
 275 >       Let (Rec ds) 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)
 282 >
 283 >       SCC l e ->
 284 >               uniqueExpr p t e                `thenUs` \e ->
 285 >               returnUs (SCC l e)
 286 >
 287 >       Coerce _ _ _ -> panic "DefUtils.uniqueExpr:Coerce"
 288 >
 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)
 294 >
 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 _ _"
 302
 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 (?)
 306
 307 > lookup :: Id -> IdEnv Id -> Id
 308 > lookup id p =
 309 >       case lookupIdEnv p id of
 310 >               Nothing -> id
 311 >               Just new_id -> new_id
 312
 313 > newVar :: TypeEnv -> Id -> UniqSM Id
 314 > newVar t id =
 315 >       getUnique               `thenUs` \u ->
 316 >       returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
 317
 318 -----------------------------------------------------------------------------
 319 \subsection{Detecting Renamings}
 320
 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
 325 expression).
 326
 327 We only allow renaming of sysLocal ids - ie. not top-level, imported
 328 or otherwise global ids.
 329
 330 > data RenameResult
 331 >       = NotRenaming
 332 >       | IsRenaming [(Id,Id)]
 333 >       | InconsistentRenaming [(Id,Id)]
 334
 335 > renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
 336 > renameExprs u u' =
 337 >       case ren u u' of
 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 >                                      ppShow 80 (ppr PprDebug u) ++ "\n" ++
 344 >                                      ppShow 80 (ppr PprDebug u'))
 345 >                               (returnUs (InconsistentRenaming r))
 346 >                       else
 347 >                               trace "Renaming!" (returnUs (IsRenaming r))
 348 >               _ -> panic "DefUtils(renameExprs)"
 349
 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
 352 same variable.
 353
 354 > consistent :: [(Id,Id)] -> Bool
 355 > consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ]
 356
 357 > checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
 358 > checkConsistency bound free = [ r' | r <- free, r' <- check r ]
 359 >       where
 360 >          check r | they're_consistent = [frees]
 361 >                  | otherwise          = []
 362 >               where
 363 >                  (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
 364 >                  (lbound,rbound) = unzip bound
 365 >                  they're_consistent = consistent (bound ++ bounds)
 366
 367 Renaming composition operator.
 368
 369 > (....) :: [[a]] -> [[a]] -> [[a]]
 370 > r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ]
 371
 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..)
 378
 379 Main renaming function.  Returns a list of renamings made while
 380 comparing the expressions.
 381
 382 > ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
 383 >
 384 >       -- renaming or identical cases --
 385 >
 386 >
 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)]]
 391 >
 392 >       -- if we're doing matching, use the next rule,
 393 >       -- and delete the second clause in the above rule.
 394 > {-
 395 > ren (Var (DefArgVar x)) t
 396 >       | okToRename x && all (not. deforestable) (freeVars t)
 397 >       = [[(x,t)]]
 398 > -}
 399
 400 > ren (Lit l) (Lit l') | l == l'
 401 >       = [[]]
 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')
 409 >       = ren e e'                      -- XXX!
 410 > ren (App e v) (App e' v')
 411 >       = ren e e' .... renAtom v v'
 412 > ren (CoTyApp e t) (CoTyApp e' t')
 413 >       = ren e e'                      -- XXX!
 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'
 423 >
 424 >       -- label cases --
 425 >
 426 > ren (Var (Label l e)) e'      = ren l e'
 427 > ren e (Var (Label l e'))      = ren e l
 428 >
 429 >       -- error cases --
 430 >
 431 > ren (Var (DefArgExpr _)) _
 432 >       = panic "DefUtils(ren): Var (DefArgExpr _)"
 433 > ren _ (Var (DefArgExpr _))
 434 >       = panic "DefUtils(ren): Var (DefArgExpr _)"
 435 >
 436 >       -- default case --
 437 >
 438 > ren _ _ = []
 439
 440 Rename atoms.
 441
 442 > renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
 443 >       = ren e 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 _ _)"
 454 >
 455 > renAtom _ _ = []
 456
 457 Renamings of case alternatives doesn't allow reordering, but that
 458 should be Ok (we don't ever change the ordering anyway).
 459
 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'
 464 > renAlts _ _ = []
 465 >
 466 > renAlgAlt (c,vs,e) (c',vs',e') | c == c'
 467 >       = checkConsistency (zip vs vs') (ren e e')
 468 > renAlgAlt _ _ = []
 469 >
 470 > renPrimAlt (l,e) (l',e') | l == l' = ren e e'
 471 > renPrimAlt _ _ = []
 472 >
 473 > renDefault NoDefault NoDefault = [[]]
 474 > renDefault (BindDefault v e) (BindDefault v' e')
 475 >       = checkConsistency [(v,v')] (ren e e')
 476
 477 -----------------------------------------------------------------------------
 478
 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 _)"
 486
 487 > expr2atom = VarArg . DefArgExpr
 488
 489 -----------------------------------------------------------------------------
 490 Grab a new Id and tag it as coming from the Deforester.
 491
 492 > newDefId :: Type -> UniqSM Id
 493 > newDefId t =
 494 >       getUnique       `thenUs` \u ->
 495 >       returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
 496
 497 > newTmpId :: Type -> UniqSM Id
 498 > newTmpId t =
 499 >       getUnique       `thenUs` \u ->
 500 >       returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
 501
 502 -----------------------------------------------------------------------------
 503 Check whether an Id was given a `DEFOREST' annotation by the programmer.
 504
 505 > deforestable :: Id -> Bool
 506 > deforestable id =
 507 >       case getInfo (getIdInfo id) of
 508 >               DoDeforest -> True
 509 >               Don'tDeforest -> False
 510
 511 -----------------------------------------------------------------------------
 512 Filter for free variables to abstract from new functions.
 513
 514 > isArgId id
 515 >       =    (not . deforestable)  id
 516 >         && (not . toplevelishId) id
 517
 518 -----------------------------------------------------------------------------
 519
 520 > foldrSUs f c [] = returnUs c
 521 > foldrSUs f c (x:xs)
 522 >       = foldrSUs f c xs       `thenUs` \xs' ->
 523 >         f x xs'
 524
 525 -----------------------------------------------------------------------------
 526
 527 > mkDefLetrec [] e = e
 528 > mkDefLetrec bs e = Let (Rec bs) e
 529
 530 -----------------------------------------------------------------------------
 531 Substitutions.
 532
 533 > subst :: [(Id,DefExpr)]
 534 >       -> DefExpr
 535 >       -> UniqSM DefExpr
 536
 537 > subst p e' = sub e'
 538 >  where
 539 >     p' = mkIdEnv p
 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 ->
 558 >                               returnUs (App e 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)
 571 >                       where
 572 >                               substBind (v,e) =
 573 >                                       sub e           `thenUs` \e ->
 574 >                                       returnUs (v,e)
 575 >       SCC l e            -> sub e                     `thenUs` \e ->
 576 >                               returnUs (SCC l e)
 577 >
 578 >       Coerce _ _ _ -> panic "DefUtils.subst:Coerce"
 579
 580 >     substAtom (VarArg v) =
 581 >               substArg v `thenUs` \v ->
 582 >               returnUs (VarArg v)
 583 >     substAtom (LitArg l) =
 584 >               returnUs (LitArg l)     -- XXX
 585
 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
 596
 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)
 605
 606 >     substAlgAlt  (c, vs, e) =
 607 >               sub e                           `thenUs` \e ->
 608 >               returnUs (c, vs, e)
 609 >     substPrimAlt (l, e) =
 610 >               sub e                           `thenUs` \e ->
 611 >               returnUs (l, e)
 612
 613 >     substDefault NoDefault =
 614 >               returnUs NoDefault
 615 >     substDefault (BindDefault v e) =
 616 >               sub e                           `thenUs` \e ->
 617 >               returnUs (BindDefault v e)
 618
 619 -----------------------------------------------------------------------------
 620
 621 > union [] ys = ys
 622 > union (x:xs) ys
 623 >       | x `is_elem` ys = union xs ys
 624 >       | otherwise   = x : union xs ys
 625 >   where { is_elem = isIn "union(deforest)" }