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