ghc/compiler/deforest/DefExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[DefExpr]{Transformation Algorithm for Expressions}
   5
   6 >#include "HsVersions.h"
   7
   8 > module DefExpr (
   9 >       tran
  10 >       ) where
  11 >
  12 > import DefSyn
  13 > import CoreSyn
  14 > import DefUtils
  15 > import Core2Def       ( c2d )                 -- for unfoldings
  16 > import TreelessForm
  17 > import Cyclic
  18
  19 > import AbsUniType     ( applyTypeEnvToTy, isPrimType,
  20 >                         SigmaType(..), UniType
  21 >                         IF_ATTACK_PRAGMAS(COMMA cmpUniType)
  22 >                       )
  23 > import CmdLineOpts    ( SwitchResult, switchIsOn )
  24 > import CoreFuns       ( mkCoLam, unTagBinders, typeOfCoreExpr )
  25 > import Id             ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
  26 >                         isInstId_maybe
  27 >                       )
  28 > import Inst           -- Inst(..)
  29 > import IdEnv
  30 > import IdInfo
  31 > import Maybes         ( Maybe(..) )
  32 > import Outputable
  33 > import SimplEnv       ( SwitchChecker(..), UnfoldingDetails(..) )
  34 > import SplitUniq
  35 > import TyVarEnv
  36 > import Util
  37
  38 > -- tmp
  39 > import Pretty
  40 > import Def2Core
  41
  42 -----------------------------------------------------------------------------
  43 Top level transformation
  44
  45 A type environment mapping type variables to types is carried around.
  46 This is extended by one rule only: reduction of a type application.
  47
  48 > tran
  49 >       :: SwitchChecker who_knows
  50 >       -> IdEnv DefExpr                -- Environment
  51 >       -> TypeEnv                      -- Type environment
  52 >       -> DefExpr                      -- input expression
  53 >       -> [DefCoreArg]                 -- args
  54 >       -> SUniqSM DefExpr
  55
  56 > tran sw p t e@(CoVar (DefArgVar id)) as =
  57 >       tranVar sw p id
  58 >               (
  59 >                mapArgs (\e -> tran sw p t e []) as  `thenSUs` \as ->
  60 >                returnSUs (applyToArgs (CoVar (DefArgVar new_id)) as)
  61 >               )
  62 >               (
  63 >                \e ->
  64 >                  tran sw p t e as     `thenSUs` \e ->
  65 >                  returnSUs (mkLabel (applyToArgs (CoVar (DefArgVar new_id))
  66 >                                       (map (substTyArg t) as))
  67 >                                     e)
  68 >               )
  69 >       where new_id = applyTypeEnvToId t id
  70
  71 > tran sw p t e@(CoLit l) [] =
  72 >       returnSUs e
  73 >
  74 > tran sw p t (CoCon c ts es) [] =
  75 >       mapSUs (tranAtom sw p t) es             `thenSUs` \es ->
  76 >       returnSUs (CoCon c (map (applyTypeEnvToTy t) ts) es)
  77 >
  78 > tran sw p t (CoPrim op ts es) [] =    -- XXX constant folding?
  79 >       mapSUs (tranAtom sw p t) es     `thenSUs` \es ->
  80 >       returnSUs (CoPrim op (map (applyTypeEnvToTy t) ts) es)
  81 >
  82 > tran sw p t (CoLam vs e) [] =
  83 >       tran sw p t e []                        `thenSUs` \e ->
  84 >       returnSUs (mkCoLam (map (applyTypeEnvToId t) vs) e)
  85 >
  86 > tran sw p t (CoLam vs e) as =
  87 >       subst s e                               `thenSUs` \e ->
  88 >       tran sw p t (mkCoLam rvs e) ras
  89 >   where
  90 >       (rvs,ras,s) = mkSubst vs as []
  91
  92 > tran sw p t (CoTyLam alpha e) [] =
  93 >       tran sw p t e []                        `thenSUs` \e ->
  94 >       returnSUs (CoTyLam alpha e)
  95 >
  96
  97         ToDo: use the environment rather than doing explicit substitution
  98         (didn't work last time I tried :)
  99
 100 > tran sw p t (CoTyLam alpha e) (TypeArg ty : as) =
 101 >       tran sw p t (applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e) as
 102
 103 > tran sw p t (CoApp e v) as =
 104 >       maybeJumbleApp e v                      `thenSUs` \j ->
 105 >       case j of
 106 >               Nothing -> tran sw p t e (ValArg v : as)
 107 >               Just e' -> tran sw p t e' as
 108 >
 109 > tran sw p t (CoTyApp e ty) as =
 110 >       tran sw p t e (TypeArg (applyTypeEnvToTy t ty) : as)
 111 >
 112 > tran sw p t (CoLet (CoNonRec v e) e') as =
 113 >       tran sw p t e []                        `thenSUs` \e  ->
 114 >       if isConstant e then
 115 >               trace "yippee!!" $
 116 >               subst [(v,removeLabels e)] e'           `thenSUs` \e' ->
 117 >               tran sw p t e' as
 118 >       else
 119 >               tran sw p t e' as               `thenSUs` \e' ->
 120 >               returnSUs (CoLet (CoNonRec (applyTypeEnvToId t v) e) e')
 121 >
 122 > tran sw p t (CoLet (CoRec bs) e) as =
 123 >       tranRecBinds sw p t bs e                `thenSUs` \(p',resid,e) ->
 124 >       tran sw p' t e as                       `thenSUs` \e ->
 125 >       returnSUs (mkDefLetrec resid e)
 126 >
 127 > tran sw p t (CoSCC l e) as =
 128 >       tran sw p t e []                        `thenSUs` \e ->
 129 >       mapArgs (\e -> tran sw p t e []) as     `thenSUs` \as ->
 130 >       returnSUs (applyToArgs (CoSCC l e) as)
 131 >
 132 > tran sw p t (CoCase e ps) as =
 133 >       tranCase sw p t e [] ps as
 134 >
 135 > tran _ _ _ e as =
 136 >       defPanic "DefExpr" "tran" (applyToArgs e as)
 137
 138 -----------------------------------------------------------------------------
 139 Transformation for case expressions of the form (case e1..en of {..})
 140
 141 > tranCase
 142 >       :: SwitchChecker who_knows
 143 >       -> IdEnv DefExpr
 144 >       -> TypeEnv
 145 >       -> DefExpr
 146 >       -> [DefCoreArg]
 147 >       -> DefCaseAlternatives
 148 >       -> [DefCoreArg]
 149 >       -> SUniqSM DefExpr
 150
 151 > tranCase sw p t e bs ps as = case e of
 152 >
 153 >       CoVar (DefArgVar id) ->
 154 >               tranVar sw p id
 155 >                  (
 156 >                    tranAlts sw p t ps as      `thenSUs` \ps ->
 157 >                    mapArgs (\e -> tran sw p t e []) bs  `thenSUs` \bs ->
 158 >                    returnSUs
 159 >                         (CoCase
 160 >                          (applyToArgs (CoVar (DefArgVar
 161 >                                                 (applyTypeEnvToId t id)))
 162 >                                 bs)
 163 >                          ps)
 164 >                  )
 165 >                  (
 166 >                    \e ->
 167 >                    tranCase sw p t e bs ps as `thenSUs` \e ->
 168 >                    returnSUs
 169 >                      (mkLabel
 170 >                          (applyToArgs
 171 >                             (CoCase (applyToArgs (CoVar (DefArgVar id))
 172 >                                       (map (substTyArg t) bs))
 173 >                                     ps)
 174 >                             (map (substTyArg t) as))
 175 >                          e)
 176 >                  )
 177 >
 178 >       CoLit l ->
 179 >               case bs of
 180 >                 [] -> tranAlts sw p t ps as           `thenSUs` \ps ->
 181 >                       returnSUs (CoCase e ps)
 182 >                 _ -> die_horribly
 183 >
 184 >       CoPrim op ts es ->
 185 >               case bs of
 186 >                 [] -> tranAlts sw p t ps as           `thenSUs` \ps ->
 187 >                       mapSUs (tranAtom sw p t) es     `thenSUs` \es ->
 188 >                       returnSUs (CoCase (CoPrim op
 189 >                                       (map (applyTypeEnvToTy t) ts) es) ps)
 190 >                 _ -> die_horribly
 191 >
 192 >       CoCon c ts es ->
 193 >               case bs of
 194 >                 [] -> case ps of
 195 >                         CoAlgAlts alts def ->
 196 >                               reduceCase sw p c ts es alts def as
 197 >                         CoPrimAlts alts def -> die_horribly
 198 >                 _ -> die_horribly
 199 >
 200 >       CoLam vs e ->
 201 >               case bs of
 202 >                       [] -> die_horribly
 203 >                       (TypeArg _ : _) -> die_horribly
 204 >                       _ -> subst s e          `thenSUs` \e ->
 205 >                            tranCase sw p t e rbs ps as
 206 >          where
 207 >               (rvs,rbs,s) = mkSubst vs bs []
 208 >
 209 >       CoTyLam alpha e ->
 210 >               case bs of
 211 >                 TypeArg ty : bs' -> tranCase sw p t e' bs' ps as
 212 >                    where e' = applyTypeEnvToExpr (mkTyVarEnv [(alpha,ty)]) e
 213 >                 _ -> die_horribly
 214 >
 215 >       CoApp e v ->
 216 >               maybeJumbleApp e v                      `thenSUs` \j ->
 217 >               case j of
 218 >                       Nothing -> tranCase sw p t e (ValArg v : bs) ps as
 219 >                       Just e' -> tranCase sw p t e' bs ps as
 220 >
 221 >       CoTyApp e ty ->
 222 >               tranCase sw p t e (TypeArg (applyTypeEnvToTy t ty) : bs)
 223 >                       ps as
 224 >
 225 >       CoLet (CoNonRec v e) e' ->
 226 >               tran sw p t e []                        `thenSUs` \e  ->
 227 >               if isConstant e then
 228 >                       trace "yippee2!!" $
 229 >                       subst [(v,removeLabels e)] e'   `thenSUs` \e' ->
 230 >                       tranCase sw p t e' bs ps as
 231 >               else
 232 >                       tranCase sw p t e' bs ps as     `thenSUs` \e' ->
 233 >                       returnSUs (CoLet (CoNonRec
 234 >                                               (applyTypeEnvToId t v) e) e')
 235 >
 236 >       CoLet (CoRec binds) e ->
 237 >               tranRecBinds sw p t binds e     `thenSUs` \(p',resid,e) ->
 238 >               tranCase sw p' t e bs ps as             `thenSUs` \e ->
 239 >               returnSUs (mkDefLetrec resid e)
 240 >
 241 >       -- ToDo: sort out cost centres.  Currently they act as a barrier
 242 >       -- to optimisation.
 243 >       CoSCC l e ->
 244 >               tran sw p t e []                        `thenSUs` \e ->
 245 >               mapArgs (\e -> tran sw p t e []) bs
 246 >                                                       `thenSUs` \bs ->
 247 >               tranAlts sw p t ps as                   `thenSUs` \ps ->
 248 >               returnSUs (CoCase (applyToArgs (CoSCC l e) bs)
 249 >                                 ps)
 250 >
 251 >       CoCase e ps' ->
 252 >               tranCase sw p t e []
 253 >                    (mapAlts (\e -> applyToArgs (CoCase e ps) bs) ps') as
 254 >
 255 >       _ -> die_horribly
 256 >
 257 >    where die_horribly = defPanic "DefExpr" "tranCase"
 258 >                       (applyToArgs (CoCase (applyToArgs e bs) ps) as)
 259
 260 -----------------------------------------------------------------------------
 261 Deciding whether or not to replace a function variable with it's
 262 definition.  The tranVar function is passed four arguments: the
 263 environment, the Id itself, the expression to return if no
 264 unfolding takes place, and a function to apply to the unfolded expression
 265 should an unfolding be required.
 266
 267 > tranVar
 268 >       :: SwitchChecker who_knows
 269 >       -> IdEnv DefExpr
 270 >       -> Id
 271 >       -> SUniqSM DefExpr
 272 >       -> (DefExpr -> SUniqSM DefExpr)
 273 >       -> SUniqSM DefExpr
 274 >
 275 > tranVar sw p id no_unfold unfold_with =
 276 >
 277 >   case lookupIdEnv p id of
 278 >       Just e' ->
 279 >               rebindExpr e'   `thenSUs` \e' ->
 280 >               if deforestable id
 281 >                  then unfold_with e'
 282 >                  else panic "DefExpr(tran): not deforestable id in env"
 283
 284         No mapping in the environment, but it could be an
 285         imported function that was annotated with DEFOREST,
 286         in which case it will have an unfolding inside the Id
 287         itself.
 288
 289 >       Nothing ->
 290 >         if (not . deforestable) id
 291 >               then  no_unfold
 292 >
 293 >               else case (getIdUnfolding id) of
 294 >                       GeneralForm _ _ expr guidance ->
 295 >                         panic "DefExpr:GeneralForm has changed a little; needs mod here"
 296 >                         -- SLPJ March 95
 297 >
 298 >--???                    -- ToDo: too much overhead here.
 299 >--???                    let e' = c2d nullIdEnv expr in
 300 >--???                    convertToTreelessForm sw e'   `thenSUs` \e'' ->
 301 >--???                    unfold_with e''
 302 >                       _ -> no_unfold
 303
 304                            If the unfolding isn't present, this is
 305                            a sign that the function is from this module and
 306                            is not in the environemnt yet (maybe because
 307                            we are transforming the body of the definition
 308                            itself).
 309
 310 >                       {- panic
 311 >                               ("DefExpr(tran): Deforestable id `"
 312 >                               ++ ppShow 80 (ppr PprDebug id)
 313 >                               ++ "' doesn't have an unfolding.") -}
 314
 315 -----------------------------------------------------------------------------
 316 Transform a set of case alternatives.
 317
 318 > tranAlts
 319 >       :: SwitchChecker who_knows
 320 >       -> IdEnv DefExpr
 321 >       -> TypeEnv
 322 >       -> DefCaseAlternatives
 323 >       -> [DefCoreArg]
 324 >       -> SUniqSM DefCaseAlternatives
 325
 326 > tranAlts sw p t (CoAlgAlts alts def) as =
 327 >       mapSUs (tranAlgAlt sw p t as) alts      `thenSUs` \alts ->
 328 >       tranDefault sw p t def as               `thenSUs` \def ->
 329 >       returnSUs (CoAlgAlts alts def)
 330 > tranAlts sw p t (CoPrimAlts alts def) as =
 331 >       mapSUs (tranPrimAlt sw p t as) alts     `thenSUs` \alts ->
 332 >       tranDefault sw p t def as               `thenSUs` \def ->
 333 >       returnSUs (CoPrimAlts alts def)
 334
 335 > tranAlgAlt sw p t as (c, vs, e) =
 336 >       tran sw p t e as                        `thenSUs` \e ->
 337 >       returnSUs (c, map (applyTypeEnvToId t) vs, e)
 338 > tranPrimAlt sw p t as (l, e) =
 339 >       tran sw p t e as                        `thenSUs` \e ->
 340 >       returnSUs (l, e)
 341 >
 342 > tranDefault sw p t CoNoDefault as = returnSUs CoNoDefault
 343 > tranDefault sw p t (CoBindDefault v e) as =
 344 >       tran sw p t e as                        `thenSUs` \e ->
 345 >       returnSUs (CoBindDefault (applyTypeEnvToId t v) e)
 346
 347 -----------------------------------------------------------------------------
 348 Transform an atom.
 349
 350 > tranAtom
 351 >       :: SwitchChecker who_knows
 352 >       -> IdEnv DefExpr
 353 >       -> TypeEnv
 354 >       -> DefAtom
 355 >       -> SUniqSM DefAtom
 356
 357 > tranAtom sw p t (CoVarAtom v) =
 358 >       tranArg sw p t v                        `thenSUs` \v ->
 359 >       returnSUs (CoVarAtom v)
 360 > tranAtom sw p t e@(CoLitAtom l) =     -- XXX
 361 >       returnSUs e
 362
 363 > tranArg sw p t (DefArgExpr e) =
 364 >       tran sw p t e []                        `thenSUs` \e ->
 365 >       returnSUs (DefArgExpr e)
 366 > tranArg sw p t e@(Label _ _) =
 367 >       defPanic "DefExpr" "tranArg" (CoVar e)
 368 > tranArg sw p t (DefArgVar v) =
 369 >       tran sw p t (CoVar (DefArgVar v)) []    `thenSUs` \e ->
 370 >       returnSUs (DefArgExpr e)        -- XXX remove this case
 371
 372 -----------------------------------------------------------------------------
 373 Translating recursive definition groups.
 374
 375 We first transform each binding, and then seperate the results into
 376 deforestable and non-deforestable sets of bindings.  The deforestable
 377 bindings are processed by the knot-tyer, and added to the current
 378 environment.   The rest of the bindings are returned as residual.
 379
 380 ToDo: conversion to treeless form should be unnecessary here, becuase
 381 the transformer/knot-tyer should leave things in treeless form.
 382
 383 > tranRecBinds sw p t bs e =
 384
 385 Transform all the deforestable definitions, yielding
 386         (extracted,rhss)
 387 list of extracted functions = concat extracted ok, so let's get the
 388 total set of free variables of the whole function set, call this set
 389 fvs.  Expand the argument list of each function by
 390     (fvs - freeVars rhs)
 391 and substitute the new function calls throughout the function set.
 392
 393
 394 >       let
 395 >           (unfold,resid) = partition (deforestable . fst) bs
 396 >       in
 397
 398 >       mapSUs (tranRecBind sw p t) unfold      `thenSUs` \unfold ->
 399 >       mapSUs (tranRecBind sw p t) resid       `thenSUs` \resid ->
 400
 401         Tie knots in the deforestable right-hand sides, and convert the
 402         results to treeless form. Then extract any nested deforestable
 403         recursive functions, and place everything we've got in the new
 404         environment.
 405
 406 >       let (vs,es) = unzip unfold in
 407 >       mapSUs mkLoops es                       `thenSUs` \res ->
 408 >       let
 409 >               (extracted,new_rhss) = unzip res
 410 >               new_binds = zip vs new_rhss ++ concat extracted
 411 >       in
 412
 413         Convert everything to treeless form (these functions aren't
 414         necessarily already in treeless form because the functions
 415         bound in this letrec are about to change status from not
 416         unfolded to unfolded).
 417
 418 >       mapSUs (\(v,e) ->
 419 >               convertToTreelessForm sw e      `thenSUs` \e ->
 420 >               returnSUs (v,e)) new_binds      `thenSUs` \fs ->
 421
 422         Now find the total set of free variables of this function set.
 423
 424 >       let
 425 >               fvs = filter (\id -> isArgId id{- && (not . isLitId) id-})
 426 >                       (foldr union [] (map freeVars (map snd fs)))
 427 >       in
 428
 429         Now expand the argument lists to include the total set of free vars.
 430
 431 >       let
 432 >           stuff          = [ fixupFreeVars fvs id e | (id,e) <- fs ]
 433 >           fs'            = map fst stuff
 434 >           s              = concat (map snd stuff)
 435 >           subIt (id,e)   = subst s e `thenSUs` \e -> returnSUs (id,e)
 436 >       in
 437 >       subst s e                               `thenSUs` \e  ->
 438 >       mapSUs subIt resid                      `thenSUs` \resid ->
 439 >       mapSUs subIt fs'                        `thenSUs` \fs ->
 440
 441 >       let res = returnSUs (growIdEnvList p fs, resid, e) in
 442 >       case unzip fs of
 443 >               (evs,ees) -> mapSUs d2c ees `thenSUs` \ees ->
 444 >                          let (vs',es') = unzip bs in
 445 >                          mapSUs d2c es' `thenSUs` \es' ->
 446 >                     trace ("extraction "
 447 >                               ++ showIds (map fst bs)
 448 >                               ++ showIds evs
 449 >                               ++ "\n{ input:\n" ++ (concat (map showBind (zip vs' es'))) ++ "}\n"
 450 >                               ++ "{ result:\n" ++ (concat  (map showBind (zip evs ees))) ++ "}\n") res
 451 >                  where showBind (v,e) = ppShow 80 (ppr PprDebug v) ++ "=\n" ++ ppShow 80 (ppr PprDebug e) ++ "\n"
 452
 453 > tranRecBind sw p t (id,e) =
 454 >       tran sw p t e []                        `thenSUs` \e ->
 455 >       returnSUs (applyTypeEnvToId t id,e)
 456
 457 > showIds :: [Id] -> String
 458 > showIds ids = "(" ++ concat (map ((' ' :) . ppShow 80 . ppr PprDebug) ids)
 459 >       ++ " )"
 460
 461 -----------------------------------------------------------------------------
 462
 463 > reduceCase sw p c ts es alts def as =
 464 >       case [ a | a@(c',vs,e) <- alts, c' == c ] of
 465 >               [(c,vs,e)] ->
 466 >                       subst (zip vs (map atom2expr es)) e `thenSUs` \e ->
 467 >                       tran sw p nullTyVarEnv e as
 468 >               [] -> case def of
 469 >                       CoNoDefault ->
 470 >                               panic "DefExpr(reduceCase): no match"
 471 >                       CoBindDefault v e ->
 472 >                               subst [(v,CoCon c ts es)] e `thenSUs` \e ->
 473 >                               tran sw p nullTyVarEnv e as
 474 >               _ -> panic "DefExpr(reduceCase): multiple matches"
 475
 476 -----------------------------------------------------------------------------
 477 Type Substitutions.
 478
 479 > applyTypeEnvToExpr
 480 >       :: TypeEnv
 481 >       -> DefExpr
 482 >       -> DefExpr
 483
 484 > applyTypeEnvToExpr p e = substTy e
 485 >   where
 486 >     substTy e' = case e' of
 487 >       CoVar (DefArgExpr e) -> panic "DefExpr(substTy): CoVar (DefArgExpr _)"
 488 >       CoVar (Label l e)    -> panic "DefExpr(substTy): CoVar (Label _ _)"
 489 >       CoVar (DefArgVar id) -> CoVar (DefArgVar (applyTypeEnvToId p id))
 490 >       CoLit l              -> e'
 491 >       CoCon c ts es        ->
 492 >               CoCon c (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
 493 >       CoPrim op ts es      ->
 494 >               CoPrim op (map (applyTypeEnvToTy p) ts) (map substTyAtom es)
 495 >       CoLam vs e           -> CoLam (map (applyTypeEnvToId p) vs) (substTy e)
 496 >       CoTyLam alpha e      -> CoTyLam alpha (substTy e)
 497 >       CoApp e v            -> CoApp (substTy e) (substTyAtom v)
 498 >       CoTyApp e t          -> mkCoTyApp (substTy e) (applyTypeEnvToTy p t)
 499 >       CoCase e ps          -> CoCase (substTy e) (substTyCaseAlts ps)
 500 >       CoLet (CoNonRec id e) e' ->
 501 >               CoLet (CoNonRec (applyTypeEnvToId p id) (substTy e))
 502 >                       (substTy e')
 503 >       CoLet (CoRec bs) e   ->
 504 >               CoLet (CoRec (map substTyRecBind bs)) (substTy e)
 505 >               where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
 506 >       CoSCC l e            -> CoSCC l (substTy e)
 507
 508 >     substTyAtom :: DefAtom -> DefAtom
 509 >     substTyAtom (CoVarAtom v) = CoVarAtom (substTyArg v)
 510 >     substTyAtom (CoLitAtom l) = CoLitAtom l -- XXX
 511
 512 >     substTyArg :: DefBindee -> DefBindee
 513 >     substTyArg (DefArgExpr e) = DefArgExpr (substTy e)
 514 >     substTyArg e@(Label _ _)  = panic "DefExpr(substArg): Label _ _"
 515 >     substTyArg e@(DefArgVar id)  =    -- XXX
 516 >               DefArgVar (applyTypeEnvToId p id)
 517
 518 >     substTyCaseAlts (CoAlgAlts as def)
 519 >       = CoAlgAlts (map substTyAlgAlt as) (substTyDefault def)
 520 >     substTyCaseAlts (CoPrimAlts as def)
 521 >       = CoPrimAlts (map substTyPrimAlt as) (substTyDefault def)
 522
 523 >     substTyAlgAlt  (c, vs, e) = (c, map (applyTypeEnvToId p) vs, substTy e)
 524 >     substTyPrimAlt (l, e) = (l, substTy e)
 525
 526 >     substTyDefault CoNoDefault = CoNoDefault
 527 >     substTyDefault (CoBindDefault id e) =
 528 >               CoBindDefault (applyTypeEnvToId p id) (substTy e)
 529
 530 > substTyArg t (ValArg e)   =
 531 >       ValArg (CoVarAtom (DefArgExpr (applyTypeEnvToExpr t (atom2expr e))))
 532 > substTyArg t (TypeArg ty) = TypeArg ty
 533
 534 -----------------------------------------------------------------------------
 535
 536 > mapAlts f ps = case ps of
 537 >       CoAlgAlts alts def ->
 538 >          CoAlgAlts (map (\(c,vs,e) -> (c,vs,f e)) alts) (mapDef f def)
 539 >       CoPrimAlts alts def ->
 540 >          CoPrimAlts (map (\(l,e) -> (l, f e)) alts) (mapDef f def)
 541 >
 542 > mapDef f CoNoDefault          = CoNoDefault
 543 > mapDef f (CoBindDefault v e)  = CoBindDefault v (f e)
 544
 545 -----------------------------------------------------------------------------
 546 Apply a function to all the ValArgs in an Args list.
 547
 548 > mapArgs
 549 >       :: (DefExpr -> SUniqSM DefExpr)
 550 >       -> [DefCoreArg]
 551 >       -> SUniqSM [DefCoreArg]
 552 >
 553 > mapArgs f [] =
 554 >       returnSUs []
 555 > mapArgs f (a@(TypeArg ty) : as) =
 556 >       mapArgs f as                    `thenSUs` \as ->
 557 >       returnSUs (a:as)
 558 > mapArgs f (ValArg v : as) =
 559 >       f (atom2expr v)                 `thenSUs` \e ->
 560 >       mapArgs f as                    `thenSUs` \as ->
 561 >       returnSUs (ValArg (CoVarAtom (DefArgExpr e)) : as)
 562 >
 563
 564 > mkSubst [] as s = ([],as,s)
 565 > mkSubst vs [] s = (vs,[],s)
 566 > mkSubst (v:vs) (ValArg e:as) s = mkSubst vs as ((v,atom2expr e):s)
 567
 568 -----------------------------------------------------------------------------
 569
 570 The next function does a bit of extraction for applicative terms
 571 before they are transformed.  We look for boring expressions - those
 572 that won't be any use in removing intermediate data structures.  These
 573 include applicative terms where we cannot unfold the head,
 574 non-reducible case expressions, primitive applications and some let
 575 bindings.
 576
 577 Extracting these expressions helps the knot-tyer to find loops
 578 earlier, and avoids the need to do matching instead of renaming.
 579
 580 We also pull out lets from function arguments, and primitive case
 581 expressions (which can't fail anyway).
 582
 583 Think:
 584
 585         (t (case u of x -> v))
 586         ====>
 587         let x = u in t v
 588
 589 Maybe shouldn't do this if -fpedantic-bottoms?  Also can't do it if u
 590 has an unboxed type.
 591
 592 ToDo: sort this mess out - could be more efficient.
 593
 594 > maybeJumbleApp :: DefExpr -> DefAtom -> SUniqSM (Maybe DefExpr)
 595 > maybeJumbleApp e (CoLitAtom _) = returnSUs Nothing -- ToDo remove
 596 > maybeJumbleApp e (CoVarAtom (DefArgExpr (CoVar (DefArgVar _))))
 597 >       = returnSUs Nothing
 598 > maybeJumbleApp e (CoVarAtom (DefArgExpr t))
 599 >       = let t' = pull_out t [] in
 600 >         case t' of
 601 >               CoLet _ _ -> returnSUs (Just t')
 602 >               CoCase (CoPrim _ _ _) (CoPrimAlts [] _) -> returnSUs (Just t')
 603 >               _ -> if isBoringExpr t then
 604 >                       rebind_with_let t
 605 >                    else
 606 >                       returnSUs Nothing
 607
 608 >       where isBoringExpr (CoVar (DefArgVar z)) = (not . deforestable) z
 609 >             isBoringExpr (CoPrim op ts es) = True
 610 >             isBoringExpr (CoCase e ps) = isBoringExpr e
 611 >                               && boringCaseAlternatives ps
 612 >             isBoringExpr (CoApp l r) = isBoringExpr l
 613 >             isBoringExpr (CoTyApp l t) = isBoringExpr l
 614 >             isBoringExpr _ = False
 615 >
 616 >             boringCaseAlternatives (CoAlgAlts as d) =
 617 >               all boringAlgAlt as && boringDefault d
 618 >             boringCaseAlternatives (CoPrimAlts as d) =
 619 >               all boringPrimAlt as && boringDefault d
 620 >
 621 >             boringAlgAlt  (c,xs,e) = isBoringExpr e
 622 >             boringPrimAlt (l,e)    = isBoringExpr e
 623 >
 624 >             boringDefault CoNoDefault = True
 625 >             boringDefault (CoBindDefault x e) = isBoringExpr e
 626
 627 >             pull_out (CoLet b t) as = CoLet b (pull_out t as)
 628 >             pull_out (CoApp l r) as = pull_out l (r:as)
 629 >             pull_out (CoCase prim@(CoPrim _ _ _)
 630 >                       (CoPrimAlts [] (CoBindDefault x u))) as
 631 >               = CoCase prim (CoPrimAlts [] (CoBindDefault x
 632 >                       (pull_out u as)))
 633 >             pull_out t as
 634 >               = CoApp e (CoVarAtom (DefArgExpr (foldl CoApp t as)))
 635 >
 636 >             rebind_with_let t =
 637 >                       d2c t   `thenSUs`  \core_t ->
 638 >                       newDefId (typeOfCoreExpr core_t) `thenSUs` \x ->
 639 >                       trace "boring epxr found!" $
 640 >                       returnSUs (Just (CoLet (CoNonRec x t)
 641 >                                    (CoApp e (CoVarAtom (
 642 >                                       DefArgExpr (CoVar (
 643 >                                          DefArgVar x)))))))
 644
 645 -----------------------------------------------------------------------------
 646
 647 > isLitId id = case isInstId_maybe id of
 648 >               Just (LitInst _ _ _ _) -> True
 649 >               _ -> False
 650
 651 > isConstant (CoCon c [] []) = True
 652 > isConstant (CoLit l)       = True
 653 > isConstant (CoVar (Label l e)) = isConstant e
 654 > isConstant _               = False
 655
 656 > removeLabels (CoVar (Label l e)) = removeLabels e
 657 > removeLabels e = e