ghc/compiler/deforest/DefExpr.lhs

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