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