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