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