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 >                         extractTyVarsFromTy, TyVar, SigmaType(..)
  25 >                         IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
  26 >                       )
  27 > import Literal        ( Literal )     -- for Eq Literal
  28 > import CoreSyn
  29 > import Id             ( mkIdWithNewUniq, mkSysLocal, applyTypeEnvToId,
  30 >                         getIdInfo, toplevelishId, idType, Id )
  31 > import IdInfo
  32 > import Outputable
  33 > import Pretty
  34 > import PrimOp ( PrimOp )      -- for Eq PrimOp
  35 > import UniqSupply
  36 > import SrcLoc         ( mkUnknownSrcLoc )
  37 > import Util
  38
  39 -----------------------------------------------------------------------------
  40 \susbsection{Strip}
  41
  42 Implementation of the strip function.  Strip is the identity on
  43 expressions (recursing into subterms), but replaces each label with
  44 its left hand side.  The result is a term with no labels.
  45
  46 > strip :: DefExpr -> DefExpr
  47
  48 > strip e' = case e' of
  49 >       Var (DefArgExpr e) -> panic "DefUtils(strip): Var (DefExpr _)"
  50 >       Var (Label l e)    -> l
  51 >       Var (DefArgVar v)  -> e'
  52 >       Lit l              -> e'
  53 >       Con c ts es        -> Con c ts (map stripAtom es)
  54 >       Prim op ts es      -> Prim op ts (map stripAtom es)
  55 >       Lam vs e           -> Lam vs (strip e)
  56 >       CoTyLam alpha e      -> CoTyLam alpha (strip e)
  57 >       App e v            -> App (strip e) (stripAtom v)
  58 >       CoTyApp e t          -> CoTyApp (strip e) t
  59 >       Case e ps          -> Case (strip e) (stripCaseAlts ps)
  60 >       Let (NonRec v e) e' -> Let (NonRec v (strip e)) (strip e')
  61 >       Let (Rec bs) e   ->
  62 >               Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e)
  63 >       SCC l e            -> SCC l (strip e)
  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
 117 >       free' :: [Id] -> [Id] -> [Id]
 118 >       free' vs fvs = filter (\x -> notElem x vs) fvs
 119
 120 >       freeAtom (VarArg (DefArgExpr e)) fvs = free e fvs
 121 >       freeAtom (VarArg (Label l e)) fvs
 122 >               = panic "DefUtils(free): VarArg (Label _ _)"
 123 >       freeAtom (VarArg (DefArgVar v)) fvs
 124 >               = panic "DefUtils(free): VarArg (DefArgVar _ _)"
 125 >       freeAtom (LitArg l) fvs = fvs
 126
 127 >       freeCaseAlts (AlgAlts as def) fvs
 128 >               = foldr freeAlgAlt  (freeDefault def fvs) as
 129 >       freeCaseAlts (PrimAlts as def) fvs
 130 >               = foldr freePrimAlt (freeDefault def fvs) as
 131 >
 132 >       freeAlgAlt  (c, vs, e) fvs = free' vs (free e fvs)
 133 >       freePrimAlt (l, e) fvs = free e fvs
 134
 135 >       freeDefault NoDefault fvs = fvs
 136 >       freeDefault (BindDefault v e) fvs = free' [v] (free e fvs)
 137
 138 -----------------------------------------------------------------------------
 139 \subsection{Free Type Variables}
 140
 141 > freeTyVars :: DefExpr -> [TyVar]
 142 > freeTyVars e = free e []
 143 >   where
 144 >       free e tvs = case e of
 145 >               Var (DefArgExpr e)    ->
 146 >                       panic "DefUtils(freeVars): Var (DefExpr _)"
 147 >               Var (Label l e)       -> free l tvs
 148 >               Var (DefArgVar id)    -> freeId id tvs
 149 >               Lit l                 -> tvs
 150 >               Con c ts es           -> foldr freeTy (foldr freeAtom tvs es) ts
 151 >               Prim op ts es         -> foldr freeTy (foldr freeAtom tvs es) ts
 152 >               Lam vs e              -> foldr freeId (free e tvs) vs
 153 >               CoTyLam alpha e         -> filter (/= alpha) (free e tvs)
 154 >               App e v               -> free e (freeAtom v tvs)
 155 >               CoTyApp e t             -> free e (freeTy t tvs)
 156 >               Case e ps             -> free e (freeCaseAlts ps tvs)
 157 >               Let (NonRec v e) e' -> free e (freeId v (free e' tvs))
 158 >               Let (Rec bs) e      -> foldr freeBind (free e tvs) bs
 159 >               SCC l e               -> free e tvs
 160 >
 161 >       freeId id tvs = extractTyVarsFromTy (idType id) `union` tvs
 162 >       freeTy t  tvs = extractTyVarsFromTy t `union` tvs
 163 >       freeBind (v,e) tvs = freeId v (free e tvs)
 164
 165 >       freeAtom (VarArg (DefArgExpr e)) tvs = free e tvs
 166 >       freeAtom (VarArg (Label l e)) tvs
 167 >               = panic "DefUtils(freeVars): VarArg (Label _ _)"
 168 >       freeAtom (VarArg (DefArgVar v)) tvs
 169 >               = panic "DefUtils(freeVars): VarArg (DefArgVar _ _)"
 170 >       freeAtom (LitArg l) tvs = tvs   -- XXX
 171
 172 >       freeCaseAlts (AlgAlts as def) tvs
 173 >               = foldr freeAlgAlt  (freeDefault def tvs) as
 174 >       freeCaseAlts (PrimAlts as def) tvs
 175 >               = foldr freePrimAlt (freeDefault def tvs) as
 176
 177 >       freeAlgAlt  (c, vs, e) tvs = foldr freeId (free e tvs) vs
 178 >       freePrimAlt (l, e) tvs = free e tvs
 179
 180 >       freeDefault NoDefault tvs = tvs
 181 >       freeDefault (BindDefault v e) tvs = freeId v (free e tvs)
 182
 183 -----------------------------------------------------------------------------
 184 \subsection{Rebinding variables in an expression}
 185
 186 Here is the code that renames all the bound variables in an expression
 187 with new uniques.  Free variables are left unchanged.
 188
 189 > rebindExpr :: DefExpr -> UniqSM DefExpr
 190 > rebindExpr e = uniqueExpr nullIdEnv nullTyVarEnv e
 191
 192 > uniqueExpr :: IdEnv Id -> TypeEnv -> DefExpr -> UniqSM DefExpr
 193 > uniqueExpr p t e =
 194 >   case e of
 195 >       Var (DefArgVar v) ->
 196 >               returnUs (Var (DefArgVar (lookup v p)))
 197 >
 198 >       Var (Label l e) ->
 199 >               uniqueExpr p t l                `thenUs` \l ->
 200 >               uniqueExpr p t e                `thenUs` \e ->
 201 >               returnUs (mkLabel l e)
 202 >
 203 >       Var (DefArgExpr _) ->
 204 >               panic "DefUtils(uniqueExpr): Var(DefArgExpr _)"
 205 >
 206 >       Lit l ->
 207 >               returnUs e
 208 >
 209 >       Con c ts es ->
 210 >               mapUs (uniqueAtom p t) es       `thenUs` \es ->
 211 >               returnUs (Con c (map (applyTypeEnvToTy t) ts) es)
 212 >
 213 >       Prim op ts es ->
 214 >               mapUs (uniqueAtom p t) es        `thenUs` \es ->
 215 >               returnUs (Prim op (map (applyTypeEnvToTy t) ts) es)
 216 >
 217 >       Lam vs e ->
 218 >               mapUs (newVar t) vs             `thenUs` \vs' ->
 219 >               uniqueExpr (growIdEnvList p (zip vs vs')) t e `thenUs` \e ->
 220 >               returnUs (Lam vs' e)
 221 >
 222 >       CoTyLam v e ->
 223 >               getUnique                       `thenUs` \u ->
 224 >               let v' = cloneTyVar v u
 225 >                   t' = addOneToTyVarEnv t v (mkTyVarTy v') in
 226 >               uniqueExpr p t' e               `thenUs` \e ->
 227 >               returnUs (CoTyLam v' e)
 228 >
 229 >       App e v ->
 230 >               uniqueExpr p t e                `thenUs` \e ->
 231 >               uniqueAtom p t v                `thenUs` \v ->
 232 >               returnUs (App e v)
 233 >
 234 >       CoTyApp e ty ->
 235 >               uniqueExpr p t e                `thenUs` \e ->
 236 >               returnUs (CoTyApp e (applyTypeEnvToTy t ty))
 237 >
 238 >       Case e alts ->
 239 >               uniqueExpr p t e                `thenUs` \e ->
 240 >               uniqueAlts alts                 `thenUs` \alts ->
 241 >               returnUs (Case e alts)
 242 >            where
 243 >               uniqueAlts (AlgAlts  as d) =
 244 >                       mapUs uniqueAlgAlt  as  `thenUs` \as ->
 245 >                       uniqueDefault d         `thenUs` \d ->
 246 >                       returnUs (AlgAlts as d)
 247 >               uniqueAlts (PrimAlts as d) =
 248 >                       mapUs uniquePrimAlt as `thenUs` \as ->
 249 >                       uniqueDefault d         `thenUs` \d ->
 250 >                       returnUs (PrimAlts as d)
 251 >
 252 >               uniqueAlgAlt (c, vs, e) =
 253 >                       mapUs (newVar t) vs     `thenUs` \vs' ->
 254 >                       uniqueExpr (growIdEnvList p (zip vs vs')) t e
 255 >                                               `thenUs` \e ->
 256 >                       returnUs (c, vs', e)
 257 >               uniquePrimAlt (l, e) =
 258 >                       uniqueExpr p t e        `thenUs` \e ->
 259 >                       returnUs (l, e)
 260 >
 261 >               uniqueDefault NoDefault = returnUs NoDefault
 262 >               uniqueDefault (BindDefault v e) =
 263 >                       newVar t v      `thenUs` \v' ->
 264 >                       uniqueExpr (addOneToIdEnv p v v') t e `thenUs` \e ->
 265 >                       returnUs (BindDefault v' e)
 266 >
 267 >       Let (NonRec v e) e' ->
 268 >               uniqueExpr p t e                `thenUs` \e ->
 269 >               newVar t v                      `thenUs` \v' ->
 270 >               uniqueExpr (addOneToIdEnv p v v') t e'  `thenUs` \e' ->
 271 >               returnUs (Let (NonRec v' e) e')
 272 >
 273 >       Let (Rec ds) e ->
 274 >               let (vs,es) = unzip ds in
 275 >               mapUs (newVar t) vs             `thenUs` \vs' ->
 276 >               let p' = growIdEnvList p (zip vs vs') in
 277 >               mapUs (uniqueExpr p' t) es      `thenUs` \es ->
 278 >               uniqueExpr p' t e               `thenUs` \e ->
 279 >               returnUs (Let (Rec (zip vs' es)) e)
 280 >
 281 >       SCC l e ->
 282 >               uniqueExpr p t e                `thenUs` \e ->
 283 >               returnUs (SCC l e)
 284 >
 285 >
 286 > uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom
 287 > uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX
 288 > uniqueAtom p t (VarArg v) =
 289 >       uniqueArg p t v `thenUs` \v ->
 290 >       returnUs (VarArg v)
 291 >
 292 > uniqueArg p t (DefArgVar v) =
 293 >       panic "DefUtils(uniqueArg): DefArgVar _ _"
 294 > uniqueArg p t (DefArgExpr e) =
 295 >       uniqueExpr p t e        `thenUs` \e ->
 296 >       returnUs (DefArgExpr e)
 297 > uniqueArg p t (Label l e) =
 298 >       panic "DefUtils(uniqueArg): Label _ _"
 299
 300 We shouldn't need to apply the type environment to free variables,
 301 since their types can only contain type variables that are free in the
 302 expression as a whole (?)
 303
 304 > lookup :: Id -> IdEnv Id -> Id
 305 > lookup id p =
 306 >       case lookupIdEnv p id of
 307 >               Nothing -> id
 308 >               Just new_id -> new_id
 309
 310 > newVar :: TypeEnv -> Id -> UniqSM Id
 311 > newVar t id =
 312 >       getUnique               `thenUs` \u ->
 313 >       returnUs (mkIdWithNewUniq (applyTypeEnvToId t id) u)
 314
 315 -----------------------------------------------------------------------------
 316 \subsection{Detecting Renamings}
 317
 318 The function `renameExprs' takes two expressions and returns True if
 319 they are renamings of each other.  The variables in the list `fs' are
 320 excluded from the renaming process (i.e. if any of these variables
 321 are present in one expression, they cannot be renamed in the other
 322 expression).
 323
 324 We only allow renaming of sysLocal ids - ie. not top-level, imported
 325 or otherwise global ids.
 326
 327 > data RenameResult
 328 >       = NotRenaming
 329 >       | IsRenaming [(Id,Id)]
 330 >       | InconsistentRenaming [(Id,Id)]
 331
 332 > renameExprs :: DefExpr -> DefExpr -> UniqSM RenameResult
 333 > renameExprs u u' =
 334 >       case ren u u' of
 335 >               []   -> returnUs NotRenaming
 336 >               [r] -> if not (consistent r) then
 337 >                               d2c (strip u)   `thenUs` \u ->
 338 >                               d2c (strip u')  `thenUs` \u' ->
 339 >                               trace ("failed consistency check:\n" ++
 340 >                                      ppShow 80 (ppr PprDebug u) ++ "\n" ++
 341 >                                      ppShow 80 (ppr PprDebug u'))
 342 >                               (returnUs (InconsistentRenaming r))
 343 >                       else
 344 >                               trace "Renaming!" (returnUs (IsRenaming r))
 345 >               _ -> panic "DefUtils(renameExprs)"
 346
 347 Check that we have a consistent renaming.  A renaming is consistent if
 348 each time variable x in expression 1 is renamed, it is renamed to the
 349 same variable.
 350
 351 > consistent :: [(Id,Id)] -> Bool
 352 > consistent rs = and [ y == y' | (x,y) <- rs, (x',y') <- rs, x == x' ]
 353
 354 > checkConsistency :: [(Id,Id)] -> [[(Id,Id)]] -> [[(Id,Id)]]
 355 > checkConsistency bound free = [ r' | r <- free, r' <- check r ]
 356 >       where
 357 >          check r | they're_consistent = [frees]
 358 >                  | otherwise          = []
 359 >               where
 360 >                  (bounds,frees) = partition (\(a,b) -> a `elem` lbound) r
 361 >                  (lbound,rbound) = unzip bound
 362 >                  they're_consistent = consistent (bound ++ bounds)
 363
 364 Renaming composition operator.
 365
 366 > (....) :: [[a]] -> [[a]] -> [[a]]
 367 > r .... r' = [ xs ++ xs' | xs <- r, xs' <- r' ]
 368
 369 The class of identifiers which can be renamed.  It is sensible to
 370 disallow renamings of deforestable ids, but the top-level ones are a
 371 bit iffy.  Ideally, we should allow renaming of top-level ids, but the
 372 current scheme allows us to leave out the top-level ids from the
 373 argument lists of new function definitions.  (we still have the
 374 shadowed ones to worry about..)
 375
 376 Main renaming function.  Returns a list of renamings made while
 377 comparing the expressions.
 378
 379 > ren :: DefExpr -> DefExpr -> [[(Id,Id)]]
 380 >
 381 >       -- renaming or identical cases --
 382 >
 383 >
 384 >       -- same variable, no renaming
 385 > ren (Var (DefArgVar x)) t@(Var (DefArgVar y))
 386 >       | x == y = [[(x,y)]]
 387 >       | isArgId x && isArgId y = [[(x,y)]]
 388 >
 389 >       -- if we're doing matching, use the next rule,
 390 >       -- and delete the second clause in the above rule.
 391 > {-
 392 > ren (Var (DefArgVar x)) t
 393 >       | okToRename x && all (not. deforestable) (freeVars t)
 394 >       = [[(x,t)]]
 395 > -}
 396
 397 > ren (Lit l) (Lit l') | l == l'
 398 >       = [[]]
 399 > ren (Con c ts es) (Con c' ts' es') | c == c'
 400 >       = foldr (....) [[]] (zipWith renAtom es es')
 401 > ren (Prim op ts es) (Prim op' ts' es') | op == op'
 402 >       = foldr (....) [[]] (zipWith renAtom es es')
 403 > ren (Lam vs e) (Lam vs' e')
 404 >       = checkConsistency (zip vs vs') (ren e e')
 405 > ren (CoTyLam vs e) (CoTyLam vs' e')
 406 >       = ren e e'                      -- XXX!
 407 > ren (App e v) (App e' v')
 408 >       = ren e e' .... renAtom v v'
 409 > ren (CoTyApp e t) (CoTyApp e' t')
 410 >       = ren e e'                      -- XXX!
 411 > ren (Case e alts) (Case e' alts')
 412 >       = ren e e' .... renAlts alts alts'
 413 > ren (Let (NonRec v a) b) (Let (NonRec v' a') b')
 414 >       = ren a a' .... (checkConsistency [(v,v')] (ren b b'))
 415 > ren (Let (Rec ds) e) (Let (Rec ds') e')
 416 >       = checkConsistency (zip vs vs')
 417 >               (ren e e' .... (foldr (....) [[]] (zipWith ren es es')))
 418 >       where (vs ,es ) = unzip ds
 419 >             (vs',es') = unzip ds'
 420 >
 421 >       -- label cases --
 422 >
 423 > ren (Var (Label l e)) e'      = ren l e'
 424 > ren e (Var (Label l e'))      = ren e l
 425 >
 426 >       -- error cases --
 427 >
 428 > ren (Var (DefArgExpr _)) _
 429 >       = panic "DefUtils(ren): Var (DefArgExpr _)"
 430 > ren _ (Var (DefArgExpr _))
 431 >       = panic "DefUtils(ren): Var (DefArgExpr _)"
 432 >
 433 >       -- default case --
 434 >
 435 > ren _ _ = []
 436
 437 Rename atoms.
 438
 439 > renAtom (VarArg (DefArgExpr e)) (VarArg (DefArgExpr e'))
 440 >       = ren e e'
 441 >  -- XXX shouldn't need the next two
 442 > renAtom (LitArg l) (LitArg l') | l == l' = [[]]
 443 > renAtom (VarArg (DefArgVar v)) _ =
 444 >       panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
 445 > renAtom _ (VarArg (DefArgVar v)) =
 446 >       panic "DefUtils(renAtom): VarArg (DefArgVar _ _)"
 447 > renAtom (VarArg (Label _ _)) _ =
 448 >       panic "DefUtils(renAtom): VarArg (Label _ _)"
 449 > renAtom e (VarArg (Label l e')) =
 450 >       panic "DefUtils(renAtom): VarArg (Label _ _)"
 451 >
 452 > renAtom _ _ = []
 453
 454 Renamings of case alternatives doesn't allow reordering, but that
 455 should be Ok (we don't ever change the ordering anyway).
 456
 457 > renAlts (AlgAlts as dflt) (AlgAlts as' dflt')
 458 >       = foldr (....) [[]] (zipWith renAlgAlt as as') .... renDefault dflt dflt'
 459 > renAlts (PrimAlts as dflt) (PrimAlts as' dflt')
 460 >       = foldr (....) [[]] (zipWith renPrimAlt as as') .... renDefault dflt dflt'
 461 > renAlts _ _ = []
 462 >
 463 > renAlgAlt (c,vs,e) (c',vs',e') | c == c'
 464 >       = checkConsistency (zip vs vs') (ren e e')
 465 > renAlgAlt _ _ = []
 466 >
 467 > renPrimAlt (l,e) (l',e') | l == l' = ren e e'
 468 > renPrimAlt _ _ = []
 469 >
 470 > renDefault NoDefault NoDefault = [[]]
 471 > renDefault (BindDefault v e) (BindDefault v' e')
 472 >       = checkConsistency [(v,v')] (ren e e')
 473
 474 -----------------------------------------------------------------------------
 475
 476 > atom2expr :: DefAtom -> DefExpr
 477 > atom2expr (VarArg (DefArgExpr e)) = e
 478 > atom2expr (VarArg (Label l e)) = mkLabel l e
 479 > -- XXX next two should be illegal
 480 > atom2expr (LitArg l) = Lit l
 481 > atom2expr (VarArg (DefArgVar v)) =
 482 >       panic "DefUtils(atom2expr): VarArg (DefArgVar _)"
 483
 484 > expr2atom = VarArg . DefArgExpr
 485
 486 -----------------------------------------------------------------------------
 487 Grab a new Id and tag it as coming from the Deforester.
 488
 489 > newDefId :: Type -> UniqSM Id
 490 > newDefId t =
 491 >       getUnique       `thenUs` \u ->
 492 >       returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
 493
 494 > newTmpId :: Type -> UniqSM Id
 495 > newTmpId t =
 496 >       getUnique       `thenUs` \u ->
 497 >       returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
 498
 499 -----------------------------------------------------------------------------
 500 Check whether an Id was given a `DEFOREST' annotation by the programmer.
 501
 502 > deforestable :: Id -> Bool
 503 > deforestable id =
 504 >       case getInfo (getIdInfo id) of
 505 >               DoDeforest -> True
 506 >               Don'tDeforest -> False
 507
 508 -----------------------------------------------------------------------------
 509 Filter for free variables to abstract from new functions.
 510
 511 > isArgId id
 512 >       =    (not . deforestable)  id
 513 >         && (not . toplevelishId) id
 514
 515 -----------------------------------------------------------------------------
 516
 517 > foldrSUs f c [] = returnUs c
 518 > foldrSUs f c (x:xs)
 519 >       = foldrSUs f c xs       `thenUs` \xs' ->
 520 >         f x xs'
 521
 522 -----------------------------------------------------------------------------
 523
 524 > mkDefLetrec [] e = e
 525 > mkDefLetrec bs e = Let (Rec bs) e
 526
 527 -----------------------------------------------------------------------------
 528 Substitutions.
 529
 530 > subst :: [(Id,DefExpr)]
 531 >       -> DefExpr
 532 >       -> UniqSM DefExpr
 533
 534 > subst p e' = sub e'
 535 >  where
 536 >     p' = mkIdEnv p
 537 >     sub e' = case e' of
 538 >       Var (DefArgExpr e) -> panic "DefExpr(sub): Var (DefArgExpr _)"
 539 >       Var (Label l e)    -> panic "DefExpr(sub): Var (Label _ _)"
 540 >       Var (DefArgVar v) ->
 541 >               case lookupIdEnv p' v of
 542 >                       Just e  -> rebindExpr e `thenUs` \e -> returnUs e
 543 >                       Nothing -> returnUs e'
 544 >       Lit l              -> returnUs e'
 545 >       Con c ts es        -> mapUs substAtom es        `thenUs` \es ->
 546 >                               returnUs (Con c ts es)
 547 >       Prim op ts es      -> mapUs substAtom es        `thenUs` \es ->
 548 >                               returnUs (Prim op ts es)
 549 >       Lam vs e           -> sub e                     `thenUs` \e ->
 550 >                               returnUs (Lam vs e)
 551 >       CoTyLam alpha e      -> sub e                   `thenUs` \e ->
 552 >                               returnUs (CoTyLam alpha e)
 553 >       App e v            -> sub e                     `thenUs` \e ->
 554 >                               substAtom v             `thenUs` \v ->
 555 >                               returnUs (App e v)
 556 >       CoTyApp e t          -> sub e                   `thenUs` \e ->
 557 >                               returnUs (CoTyApp e t)
 558 >       Case e ps          -> sub e                     `thenUs` \e ->
 559 >                               substCaseAlts ps        `thenUs` \ps ->
 560 >                               returnUs (Case e ps)
 561 >       Let (NonRec v e) e'
 562 >                            -> sub e                   `thenUs` \e ->
 563 >                               sub e'                  `thenUs` \e' ->
 564 >                               returnUs (Let (NonRec v e) e')
 565 >       Let (Rec bs) e   -> sub e                       `thenUs` \e ->
 566 >                               mapUs substBind bs      `thenUs` \bs ->
 567 >                               returnUs (Let (Rec bs) e)
 568 >                       where
 569 >                               substBind (v,e) =
 570 >                                       sub e           `thenUs` \e ->
 571 >                                       returnUs (v,e)
 572 >       SCC l e            -> sub e                     `thenUs` \e ->
 573 >                               returnUs (SCC l e)
 574
 575 >     substAtom (VarArg v) =
 576 >               substArg v `thenUs` \v ->
 577 >               returnUs (VarArg v)
 578 >     substAtom (LitArg l) =
 579 >               returnUs (LitArg l)     -- XXX
 580
 581 >     substArg (DefArgExpr e) =
 582 >               sub e           `thenUs` \e ->
 583 >               returnUs (DefArgExpr e)
 584 >     substArg e@(Label _ _)  =
 585 >               panic "DefExpr(substArg): Label _ _"
 586 >     substArg e@(DefArgVar v)  =       -- XXX
 587 >               case lookupIdEnv p' v of
 588 >                       Just e -> rebindExpr e  `thenUs` \e ->
 589 >                                 returnUs (DefArgExpr e)
 590 >                       Nothing -> returnUs e
 591
 592 >     substCaseAlts (AlgAlts as def) =
 593 >               mapUs substAlgAlt as            `thenUs` \as ->
 594 >               substDefault def                `thenUs` \def ->
 595 >               returnUs (AlgAlts as def)
 596 >     substCaseAlts (PrimAlts as def) =
 597 >               mapUs substPrimAlt as           `thenUs` \as ->
 598 >               substDefault def                `thenUs` \def ->
 599 >               returnUs (PrimAlts as def)
 600
 601 >     substAlgAlt  (c, vs, e) =
 602 >               sub e                           `thenUs` \e ->
 603 >               returnUs (c, vs, e)
 604 >     substPrimAlt (l, e) =
 605 >               sub e                           `thenUs` \e ->
 606 >               returnUs (l, e)
 607
 608 >     substDefault NoDefault =
 609 >               returnUs NoDefault
 610 >     substDefault (BindDefault v e) =
 611 >               sub e                           `thenUs` \e ->
 612 >               returnUs (BindDefault v e)
 613
 614 -----------------------------------------------------------------------------
 615
 616 > union [] ys = ys
 617 > union (x:xs) ys
 618 >       | x `is_elem` ys = union xs ys
 619 >       | otherwise   = x : union xs ys
 620 >   where { is_elem = isIn "union(deforest)" }