ghc/compiler/deforest/DefUtils.lhs

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