ghc/compiler/coreSyn/CorePrep.lhs

   1 %
   2 % (c) The University of Glasgow, 1994-2000
   3 %
   4 \section{Core pass to saturate constructors and PrimOps}
   5
   6 \begin{code}
   7 module CorePrep (
   8       corePrepPgm, corePrepExpr
   9   ) where
  10
  11 #include "HsVersions.h"
  12
  13 import CoreUtils( exprIsAtom, exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
  14 import CoreFVs  ( exprFreeVars )
  15 import CoreLint ( endPass )
  16 import CoreSyn
  17 import Type     ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
  18                   isUnLiftedType, isUnboxedTupleType, repType,
  19                   uaUTy, usOnce, usMany, eqUsage, seqType )
  20 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
  21 import PrimOp   ( PrimOp(..) )
  22 import Var      ( Var, Id, setVarUnique )
  23 import VarSet
  24 import VarEnv
  25 import Id       ( mkSysLocal, idType, idNewDemandInfo, idArity,
  26                   setIdType, isPrimOpId_maybe, isFCallId, isGlobalId,
  27                   hasNoBinding, idNewStrictness, setIdArity
  28                 )
  29 import HscTypes ( ModDetails(..) )
  30 import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel )
  31 import UniqSupply
  32 import Maybes
  33 import OrdList
  34 import ErrUtils
  35 import CmdLineOpts
  36 import Outputable
  37 \end{code}
  38
  39 -- ---------------------------------------------------------------------------
  40 -- Overview
  41 -- ---------------------------------------------------------------------------
  42
  43 The goal of this pass is to prepare for code generation.
  44
  45 1.  Saturate constructor and primop applications.
  46
  47 2.  Convert to A-normal form:
  48
  49     * Use case for strict arguments:
  50         f E ==> case E of x -> f x
  51         (where f is strict)
  52
  53     * Use let for non-trivial lazy arguments
  54         f E ==> let x = E in f x
  55         (were f is lazy and x is non-trivial)
  56
  57 3.  Similarly, convert any unboxed lets into cases.
  58     [I'm experimenting with leaving 'ok-for-speculation'
  59      rhss in let-form right up to this point.]
  60
  61 4.  Ensure that lambdas only occur as the RHS of a binding
  62     (The code generator can't deal with anything else.)
  63
  64 5.  Do the seq/par munging.  See notes with mkCase below.
  65
  66 6.  Clone all local Ids.  This means that Tidy Core has the property
  67     that all Ids are unique, rather than the weaker guarantee of
  68     no clashes which the simplifier provides.
  69
  70 7.  Give each dynamic CCall occurrence a fresh unique; this is
  71     rather like the cloning step above.
  72
  73 This is all done modulo type applications and abstractions, so that
  74 when type erasure is done for conversion to STG, we don't end up with
  75 any trivial or useless bindings.
  76
  77
  78
  79
  80 -- -----------------------------------------------------------------------------
  81 -- Top level stuff
  82 -- -----------------------------------------------------------------------------
  83
  84 \begin{code}
  85 corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
  86 corePrepPgm dflags mod_details
  87   = do  showPass dflags "CorePrep"
  88         us <- mkSplitUniqSupply 's'
  89
  90         let floats    = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
  91             new_binds = foldrOL get [] floats
  92             get (FloatLet b) bs = b:bs
  93             get b            bs = pprPanic "corePrepPgm" (ppr b)
  94
  95         endPass dflags "CorePrep" Opt_D_dump_prep new_binds
  96         return (mod_details { md_binds = new_binds })
  97
  98 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
  99 corePrepExpr dflags expr
 100   = do showPass dflags "CorePrep"
 101        us <- mkSplitUniqSupply 's'
 102        let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
 103        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep"
 104                      (ppr new_expr)
 105        return new_expr
 106
 107 -- ---------------------------------------------------------------------------
 108 -- Dealing with bindings
 109 -- ---------------------------------------------------------------------------
 110
 111 data FloatingBind = FloatLet CoreBind
 112                   | FloatCase Id CoreExpr Bool
 113                         -- The bool indicates "ok-for-speculation"
 114
 115 instance Outputable FloatingBind where
 116   ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
 117   ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
 118
 119 type CloneEnv = IdEnv Id        -- Clone local Ids
 120
 121 allLazy :: OrdList FloatingBind -> Bool
 122 allLazy floats
 123   = foldrOL check True floats
 124   where
 125     check (FloatLet _)                y = y
 126     check (FloatCase _ _ ok_for_spec) y = ok_for_spec && y
 127         -- The ok-for-speculation flag says that it's safe to
 128         -- float this Case out of a let, and thereby do it more eagerly
 129         -- We need the top-level flag because it's never ok to float
 130         -- an unboxed binding to the top level
 131
 132 -- ---------------------------------------------------------------------------
 133 --                      Bindings
 134 -- ---------------------------------------------------------------------------
 135
 136 corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind)
 137 corePrepTopBinds env [] = returnUs nilOL
 138
 139 corePrepTopBinds env (bind : binds)
 140   = corePrepTopBind env bind            `thenUs` \ (env', bind') ->
 141     corePrepTopBinds env' binds         `thenUs` \ binds' ->
 142     returnUs (bind' `appOL` binds')
 143
 144 -- NB: we do need to float out of top-level bindings
 145 -- Consider     x = length [True,False]
 146 -- We want to get
 147 --              s1 = False : []
 148 --              s2 = True  : s1
 149 --              x  = length s2
 150
 151 -- We return a *list* of bindings, because we may start with
 152 --      x* = f (g y)
 153 -- where x is demanded, in which case we want to finish with
 154 --      a = g y
 155 --      x* = f a
 156 -- And then x will actually end up case-bound
 157
 158 corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 159 corePrepTopBind env (NonRec bndr rhs)
 160   = cloneBndr env bndr                          `thenUs` \ (env', bndr') ->
 161     corePrepRhs TopLevel env (bndr, rhs)        `thenUs` \ (floats, rhs') ->
 162     returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
 163
 164 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 165
 166 corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
 167         -- This one is used for *local* bindings
 168 corePrepBind env (NonRec bndr rhs)
 169   = corePrepExprFloat env rhs                           `thenUs` \ (floats, rhs') ->
 170     cloneBndr env bndr                                  `thenUs` \ (env', bndr') ->
 171     mkLocalNonRec bndr' (bdrDem bndr') floats rhs'      `thenUs` \ floats' ->
 172     returnUs (env', floats')
 173
 174 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 175
 176 --------------------------------
 177 corePrepRecPairs :: TopLevelFlag -> CloneEnv
 178                  -> [(Id,CoreExpr)]     -- Recursive bindings
 179                  -> UniqSM (CloneEnv, OrdList FloatingBind)
 180 -- Used for all recursive bindings, top level and otherwise
 181 corePrepRecPairs lvl env pairs
 182   = cloneBndrs env (map fst pairs)              `thenUs` \ (env', bndrs') ->
 183     mapAndUnzipUs (corePrepRhs lvl env') pairs  `thenUs` \ (floats_s, rhss') ->
 184     returnUs (env', concatOL floats_s `snocOL` FloatLet (Rec (bndrs' `zip` rhss')))
 185
 186 --------------------------------
 187 corePrepRhs :: TopLevelFlag -> CloneEnv -> (Id, CoreExpr)
 188             -> UniqSM (OrdList FloatingBind, CoreExpr)
 189 -- Used for top-level bindings, and local recursive bindings
 190 corePrepRhs top_lvl env (bndr, rhs)
 191   = corePrepExprFloat env rhs           `thenUs` \ floats_w_rhs ->
 192     floatRhs top_lvl bndr floats_w_rhs
 193
 194
 195 -- ---------------------------------------------------------------------------
 196 -- Making arguments atomic (function args & constructor args)
 197 -- ---------------------------------------------------------------------------
 198
 199 -- This is where we arrange that a non-trivial argument is let-bound
 200 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 201            -> UniqSM (OrdList FloatingBind, CoreArg)
 202 corePrepArg env arg dem
 203   = corePrepExprFloat env arg           `thenUs` \ (floats, arg') ->
 204     if no_binding_needed arg'
 205     then returnUs (floats, arg')
 206     else newVar (exprType arg') (exprArity arg')        `thenUs` \ v ->
 207          mkLocalNonRec v dem floats arg'                `thenUs` \ floats' ->
 208          returnUs (floats', Var v)
 209
 210 no_binding_needed | opt_RuntimeTypes = exprIsAtom
 211                   | otherwise        = exprIsTrivial
 212
 213 -- version that doesn't consider an scc annotation to be trivial.
 214 exprIsTrivial (Var v)
 215   | hasNoBinding v                     = idArity v == 0
 216   | otherwise                          = True
 217 exprIsTrivial (Type _)                 = True
 218 exprIsTrivial (Lit lit)                = True
 219 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 220 exprIsTrivial (Note (SCC _) e)         = False
 221 exprIsTrivial (Note _ e)               = exprIsTrivial e
 222 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 223 exprIsTrivial other                    = False
 224
 225 -- ---------------------------------------------------------------------------
 226 -- Dealing with expressions
 227 -- ---------------------------------------------------------------------------
 228
 229 corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
 230 corePrepAnExpr env expr
 231   = corePrepExprFloat env expr          `thenUs` \ (floats, expr) ->
 232     mkBinds floats expr
 233
 234
 235 corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
 236 -- If
 237 --      e  ===>  (bs, e')
 238 -- then
 239 --      e = let bs in e'        (semantically, that is!)
 240 --
 241 -- For example
 242 --      f (g x)   ===>   ([v = g x], f v)
 243
 244 corePrepExprFloat env (Var v)
 245   = fiddleCCall v                               `thenUs` \ v1 ->
 246     let v2 = lookupVarEnv env v1 `orElse` v1 in
 247     maybeSaturate v2 (Var v2) 0 (idType v2)     `thenUs` \ app ->
 248     returnUs (nilOL, app)
 249
 250 corePrepExprFloat env expr@(Type _)
 251   = returnUs (nilOL, expr)
 252
 253 corePrepExprFloat env expr@(Lit lit)
 254   = returnUs (nilOL, expr)
 255
 256 corePrepExprFloat env (Let bind body)
 257   = corePrepBind env bind               `thenUs` \ (env', new_binds) ->
 258     corePrepExprFloat env' body         `thenUs` \ (floats, new_body) ->
 259     returnUs (new_binds `appOL` floats, new_body)
 260
 261 corePrepExprFloat env (Note n@(SCC _) expr)
 262   = corePrepAnExpr env expr             `thenUs` \ expr1 ->
 263     deLam expr1                         `thenUs` \ expr2 ->
 264     returnUs (nilOL, Note n expr2)
 265
 266 corePrepExprFloat env (Note other_note expr)
 267   = corePrepExprFloat env expr          `thenUs` \ (floats, expr') ->
 268     returnUs (floats, Note other_note expr')
 269
 270 corePrepExprFloat env expr@(Lam _ _)
 271   = corePrepAnExpr env body             `thenUs` \ body' ->
 272     returnUs (nilOL, mkLams bndrs body')
 273   where
 274     (bndrs,body) = collectBinders expr
 275
 276 corePrepExprFloat env (Case scrut bndr alts)
 277   = corePrepExprFloat env scrut         `thenUs` \ (floats, scrut') ->
 278     cloneBndr env bndr                  `thenUs` \ (env', bndr') ->
 279     mapUs (sat_alt env') alts           `thenUs` \ alts' ->
 280     returnUs (floats, mkCase scrut' bndr' alts')
 281   where
 282     sat_alt env (con, bs, rhs)
 283           = cloneBndrs env bs           `thenUs` \ (env', bs') ->
 284             corePrepAnExpr env' rhs     `thenUs` \ rhs1 ->
 285             deLam rhs1                  `thenUs` \ rhs2 ->
 286             returnUs (con, bs', rhs2)
 287
 288 corePrepExprFloat env expr@(App _ _)
 289   = collect_args expr 0  `thenUs` \ (app, (head,depth), ty, floats, ss) ->
 290     ASSERT(null ss)     -- make sure we used all the strictness info
 291
 292         -- Now deal with the function
 293     case head of
 294       Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' ->
 295                    returnUs (floats, app')
 296
 297       _other    -> returnUs (floats, app)
 298
 299   where
 300
 301     -- Deconstruct and rebuild the application, floating any non-atomic
 302     -- arguments to the outside.  We collect the type of the expression,
 303     -- the head of the application, and the number of actual value arguments,
 304     -- all of which are used to possibly saturate this application if it
 305     -- has a constructor or primop at the head.
 306
 307     collect_args
 308         :: CoreExpr
 309         -> Int                            -- current app depth
 310         -> UniqSM (CoreExpr,              -- the rebuilt expression
 311                    (CoreExpr,Int),        -- the head of the application,
 312                                           -- and no. of args it was applied to
 313                    Type,                  -- type of the whole expr
 314                    OrdList FloatingBind,  -- any floats we pulled out
 315                    [Demand])              -- remaining argument demands
 316
 317     collect_args (App fun arg@(Type arg_ty)) depth
 318         = collect_args fun depth   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 319           returnUs (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss)
 320
 321     collect_args (App fun arg) depth
 322         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
 323           let
 324               (ss1, ss_rest)   = case ss of
 325                                    (ss1:ss_rest) -> (ss1,     ss_rest)
 326                                    []            -> (lazyDmd, [])
 327               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
 328                                  splitFunTy_maybe fun_ty
 329           in
 330           corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
 331           returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
 332
 333     collect_args (Var v) depth
 334         = fiddleCCall v `thenUs` \ v1 ->
 335           let v2 = lookupVarEnv env v1 `orElse` v1 in
 336           returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
 337         where
 338           stricts = case idNewStrictness v of
 339                         StrictSig (DmdType _ demands _)
 340                             | depth >= length demands -> demands
 341                             | otherwise               -> []
 342                 -- If depth < length demands, then we have too few args to
 343                 -- satisfy strictness  info so we have to  ignore all the
 344                 -- strictness info, e.g. + (error "urk")
 345                 -- Here, we can't evaluate the arg strictly, because this
 346                 -- partial application might be seq'd
 347
 348
 349     collect_args (Note (Coerce ty1 ty2) fun) depth
 350         = collect_args fun depth  `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 351           returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 352
 353     collect_args (Note note fun) depth
 354         | ignore_note note
 355         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
 356           returnUs (Note note fun', hd, fun_ty, floats, ss)
 357
 358         -- non-variable fun, better let-bind it
 359     collect_args fun depth
 360         = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
 361           newVar ty (exprArity fun')                    `thenUs` \ fn_id ->
 362           mkLocalNonRec fn_id onceDem fun_floats fun'   `thenUs` \ floats ->
 363           returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
 364         where
 365           ty = exprType fun
 366
 367     ignore_note InlineCall = True
 368     ignore_note InlineMe   = True
 369     ignore_note _other     = False
 370         -- we don't ignore SCCs, since they require some code generation
 371
 372 ------------------------------------------------------------------------------
 373 -- Building the saturated syntax
 374 -- ---------------------------------------------------------------------------
 375
 376 -- maybeSaturate deals with saturating primops and constructors
 377 -- The type is the type of the entire application
 378 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 379 maybeSaturate fn expr n_args ty
 380   | hasNoBinding fn = saturate_it
 381   | otherwise       = returnUs expr
 382   where
 383     fn_arity     = idArity fn
 384     excess_arity = fn_arity - n_args
 385     saturate_it  = getUniquesUs                 `thenUs` \ us ->
 386                    returnUs (etaExpand excess_arity us expr ty)
 387
 388 -- ---------------------------------------------------------------------------
 389 -- Precipitating the floating bindings
 390 -- ---------------------------------------------------------------------------
 391
 392 floatRhs :: TopLevelFlag -> Id
 393          -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
 394          -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
 395                     CoreExpr)                   -- Final Rhs
 396
 397 floatRhs top_lvl bndr (floats, rhs)
 398   | isTopLevel top_lvl || exprIsValue rhs,      -- Float to expose value or
 399     allLazy floats                              -- at top level
 400   =     -- Why the test for allLazy?
 401         --      v = f (x `divInt#` y)
 402         -- we don't want to float the case, even if f has arity 2,
 403         -- because floating the case would make it evaluated too early
 404         --
 405         -- Finally, eta-expand the RHS, for the benefit of the code gen
 406     etaExpandRhs bndr rhs       `thenUs` \ rhs' ->
 407     returnUs (floats, rhs')
 408
 409   | otherwise
 410         -- Don't float; the RHS isn't a value
 411   = mkBinds floats rhs          `thenUs` \ rhs' ->
 412     etaExpandRhs bndr rhs'      `thenUs` \ rhs'' ->
 413     returnUs (nilOL, rhs'')
 414
 415 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 416 mkLocalNonRec :: Id  -> RhsDemand                       -- Lhs: id with demand
 417               -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
 418               -> UniqSM (OrdList FloatingBind)
 419
 420 mkLocalNonRec bndr dem floats rhs
 421   |  isUnLiftedType (idType bndr) || isStrict dem
 422         -- It's a strict let, or the binder is unlifted,
 423         -- so we definitely float all the bindings
 424   = ASSERT( not (isUnboxedTupleType (idType bndr)) )
 425     let         -- Don't make a case for a value binding,
 426                 -- even if it's strict.  Otherwise we get
 427                 --      case (\x -> e) of ...!
 428         float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
 429               | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
 430     in
 431     returnUs (floats `snocOL` float)
 432
 433   | otherwise
 434   = floatRhs NotTopLevel bndr (floats, rhs)     `thenUs` \ (floats', rhs') ->
 435     returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
 436
 437 mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
 438 mkBinds binds body
 439   | isNilOL binds = returnUs body
 440   | otherwise     = deLam body          `thenUs` \ body' ->
 441                     returnUs (foldrOL mk_bind body' binds)
 442   where
 443     mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
 444     mk_bind (FloatLet bind)        body = Let bind body
 445
 446 etaExpandRhs bndr rhs
 447   =     -- Eta expand to match the arity claimed by the binder
 448         -- Remember, after CorePrep we must not change arity
 449         --
 450         -- Eta expansion might not have happened already,
 451         -- because it is done by the simplifier only when
 452         -- there at least one lambda already.
 453         --
 454         -- NB1:we could refrain when the RHS is trivial (which can happen
 455         --     for exported things).  This would reduce the amount of code
 456         --     generated (a little) and make things a little words for
 457         --     code compiled without -O.  The case in point is data constructor
 458         --     wrappers.
 459         --
 460         -- NB2: we have to be careful that the result of etaExpand doesn't
 461         --    invalidate any of the assumptions that CorePrep is attempting
 462         --    to establish.  One possible cause is eta expanding inside of
 463         --    an SCC note - we're now careful in etaExpand to make sure the
 464         --    SCC is pushed inside any new lambdas that are generated.
 465         --
 466     getUniquesUs                `thenUs` \ us ->
 467     returnUs (etaExpand (idArity bndr) us rhs (idType bndr))
 468
 469 -- ---------------------------------------------------------------------------
 470 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 471 -- We arrange that they only show up as the RHS of a let(rec)
 472 -- ---------------------------------------------------------------------------
 473
 474 deLam :: CoreExpr -> UniqSM CoreExpr
 475 -- Remove top level lambdas by let-bindinig
 476
 477 deLam (Note n expr)
 478   =     -- You can get things like
 479         --      case e of { p -> coerce t (\s -> ...) }
 480     deLam expr  `thenUs` \ expr' ->
 481     returnUs (Note n expr')
 482
 483 deLam expr
 484   | null bndrs = returnUs expr
 485   | otherwise
 486   = case tryEta bndrs body of
 487       Just no_lam_result -> returnUs no_lam_result
 488       Nothing            -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn ->
 489                             returnUs (Let (NonRec fn expr) (Var fn))
 490   where
 491     (bndrs,body) = collectBinders expr
 492
 493 -- Why try eta reduction?  Hasn't the simplifier already done eta?
 494 -- But the simplifier only eta reduces if that leaves something
 495 -- trivial (like f, or f Int).  But for deLam it would be enough to
 496 -- get to a partial application, like (map f).
 497
 498 tryEta bndrs expr@(App _ _)
 499   | ok_to_eta_reduce f &&
 500     n_remaining >= 0 &&
 501     and (zipWith ok bndrs last_args) &&
 502     not (any (`elemVarSet` fvs_remaining) bndrs)
 503   = Just remaining_expr
 504   where
 505     (f, args) = collectArgs expr
 506     remaining_expr = mkApps f remaining_args
 507     fvs_remaining = exprFreeVars remaining_expr
 508     (remaining_args, last_args) = splitAt n_remaining args
 509     n_remaining = length args - length bndrs
 510
 511     ok bndr (Var arg) = bndr == arg
 512     ok bndr other           = False
 513
 514           -- we can't eta reduce something which must be saturated.
 515     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 516     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 517
 518 tryEta bndrs (Let bind@(NonRec b r) body)
 519   | not (any (`elemVarSet` fvs) bndrs)
 520   = case tryEta bndrs body of
 521         Just e -> Just (Let bind e)
 522         Nothing -> Nothing
 523   where
 524     fvs = exprFreeVars r
 525
 526 tryEta bndrs _ = Nothing
 527 \end{code}
 528
 529
 530 -- -----------------------------------------------------------------------------
 531 --      Do the seq and par transformation
 532 -- -----------------------------------------------------------------------------
 533
 534 Here we do two pre-codegen transformations:
 535
 536 1.      case seq# a of {
 537           0       -> seqError ...
 538           DEFAULT -> rhs }
 539   ==>
 540         case a of { DEFAULT -> rhs }
 541
 542
 543 2.      case par# a of {
 544           0       -> parError ...
 545           DEFAULT -> rhs }
 546   ==>
 547         case par# a of {
 548           DEFAULT -> rhs }
 549
 550 NB:     seq# :: a -> Int#       -- Evaluate value and return anything
 551         par# :: a -> Int#       -- Spark value and return anything
 552
 553 These transformations can't be done earlier, or else we might
 554 think that the expression was strict in the variables in which
 555 rhs is strict --- but that would defeat the purpose of seq and par.
 556
 557
 558 \begin{code}
 559 mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
 560                         -- DEFAULT alt is always first
 561   = case isPrimOpId_maybe fn of
 562         Just ParOp -> Case scrut bndr     [deflt_alt]
 563         Just SeqOp -> Case arg   new_bndr [deflt_alt]
 564         other      -> Case scrut bndr alts
 565   where
 566         -- The binder shouldn't be used in the expression!
 567     new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
 568                setIdType bndr (exprType arg)
 569         -- NB:  SeqOp :: forall a. a -> Int#
 570         -- So bndr has type Int#
 571         -- But now we are going to scrutinise the SeqOp's argument directly,
 572         -- so we must change the type of the case binder to match that
 573         -- of the argument expression e.
 574
 575 mkCase scrut bndr alts = Case scrut bndr alts
 576 \end{code}
 577
 578
 579 -- -----------------------------------------------------------------------------
 580 -- Demands
 581 -- -----------------------------------------------------------------------------
 582
 583 \begin{code}
 584 data RhsDemand
 585      = RhsDemand { isStrict :: Bool,  -- True => used at least once
 586                    isOnceDem   :: Bool   -- True => used at most once
 587                  }
 588
 589 mkDem :: Demand -> Bool -> RhsDemand
 590 mkDem strict once = RhsDemand (isStrictDmd strict) once
 591
 592 mkDemTy :: Demand -> Type -> RhsDemand
 593 mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty)
 594
 595 isOnceTy :: Type -> Bool
 596 isOnceTy ty
 597   =
 598 #ifdef USMANY
 599     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 600 #endif
 601     once
 602   where
 603     u = uaUTy ty
 604     once | u `eqUsage` usOnce  = True
 605          | u `eqUsage` usMany  = False
 606          | isTyVarTy u         = False  -- if unknown at compile-time, is Top ie usMany
 607
 608 bdrDem :: Id -> RhsDemand
 609 bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id))
 610
 611 safeDem, onceDem :: RhsDemand
 612 safeDem = RhsDemand False False  -- always safe to use this
 613 onceDem = RhsDemand False True   -- used at most once
 614 \end{code}
 615
 616
 617
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{Cloning}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626 ------------------------------------------------------------------------------
 627 -- Cloning binders
 628 -- ---------------------------------------------------------------------------
 629
 630 cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
 631 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 632
 633 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 634 cloneBndr env bndr
 635   | isGlobalId bndr             -- Top level things, which we don't want
 636   = returnUs (env, bndr)        -- to clone, have become GlobalIds by now
 637
 638   | otherwise
 639   = getUniqueUs   `thenUs` \ uniq ->
 640     let
 641         bndr' = setVarUnique bndr uniq
 642     in
 643     returnUs (extendVarEnv env bndr bndr', bndr')
 644
 645 ------------------------------------------------------------------------------
 646 -- Cloning ccall Ids; each must have a unique name,
 647 -- to give the code generator a handle to hang it on
 648 -- ---------------------------------------------------------------------------
 649
 650 fiddleCCall :: Id -> UniqSM Id
 651 fiddleCCall id
 652   | isFCallId id = getUniqueUs          `thenUs` \ uniq ->
 653                    returnUs (id `setVarUnique` uniq)
 654   | otherwise    = returnUs id
 655
 656 ------------------------------------------------------------------------------
 657 -- Generating new binders
 658 -- ---------------------------------------------------------------------------
 659
 660 newVar :: Type -> Arity -> UniqSM Id
 661 -- We're creating a new let binder, and we must give
 662 -- it the right arity for the benefit of the code generator.
 663 newVar ty arity
 664  = seqType ty                   `seq`
 665    getUniqueUs                  `thenUs` \ uniq ->
 666    returnUs (mkSysLocal SLIT("sat") uniq ty
 667              `setIdArity` arity)
 668 \end{code}