2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[CoreToStg]{Converting core syntax to STG syntax}
8 %************************************************************************
10 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
13 module CoreToStg ( topCoreBindsToStg ) where
15 #include "HsVersions.h"
17 import CoreSyn -- input
18 import StgSyn -- output
20 import CoreUtils ( coreExprType )
21 import SimplUtils ( findDefault )
22 import CostCentre ( noCCS )
23 import Id ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId,
24 externallyVisibleId, setIdUnique, idName, getIdDemandInfo
26 import Var ( Var, varType, modifyIdInfo )
27 import IdInfo ( setDemandInfo, StrictnessInfo(..) )
28 import UsageSPUtils ( primOpUsgTys )
29 import DataCon ( DataCon, dataConName, dataConId )
30 import Demand ( Demand, isStrict, wwStrict, wwLazy )
31 import Name ( Name, nameModule, isLocallyDefinedName )
32 import Module ( isDynamicModule )
33 import Const ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
35 import PrimOp ( PrimOp(..), primOpUsg, primOpSig )
36 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
37 UsageAnn(..), tyUsg, applyTy, mkUsgTy )
38 import TysPrim ( intPrimTy )
39 import UniqSupply -- all of it, really
40 import Util ( lengthExceeds )
41 import BasicTypes ( TopLevelFlag(..) )
47 *************************************************
48 *************** OVERVIEW *********************
49 *************************************************
52 The business of this pass is to convert Core to Stg. On the way it
53 does some important transformations:
55 1. We discard type lambdas and applications. In so doing we discard
56 "trivial" bindings such as
58 where t1, t2 are types
60 2. We get the program into "A-normal form". In particular:
62 f E ==> let x = E in f x
63 OR ==> case E of x -> f x
65 where E is a non-trivial expression.
66 Which transformation is used depends on whether f is strict or not.
67 [Previously the transformation to case used to be done by the
68 simplifier, but it's better done here. It does mean that f needs
69 to have its strictness info correct!.]
71 Similarly, convert any unboxed let's into cases.
72 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
73 right up to this point.]
75 3. We clone all local binders. The code generator uses the uniques to
76 name chunks of code for thunks, so it's important that the names used
77 are globally unique, not simply not-in-scope, which is all that
78 the simplifier ensures.
83 * We don't pin on correct arities any more, because they can be mucked up
84 by the lambda lifter. In particular, the lambda lifter can take a local
85 letrec-bound variable and make it a lambda argument, which shouldn't have
86 an arity. So SetStgVarInfo sets arities now.
88 * We do *not* pin on the correct free/live var info; that's done later.
89 Instead we use bOGUS_LVS and _FVS as a placeholder.
91 [Quite a bit of stuff that used to be here has moved
92 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
95 %************************************************************************
97 \subsection[coreToStg-programs]{Converting a core program and core bindings}
99 %************************************************************************
101 March 98: We keep a small environment to give all locally bound
102 Names new unique ids, since the code generator assumes that binders
103 are unique across a module. (Simplifier doesn't maintain this
104 invariant any longer.)
106 A binder to be floated out becomes an @StgFloatBind@.
109 type StgEnv = IdEnv Id
111 data StgFloatBind = NoBindF
112 | RecF [(Id, StgRhs)]
115 StgExpr -- *Can* be a StgLam
119 -- The interesting one is the NonRecF
120 -- NonRecF x rhs demand binds
122 -- x = let binds in rhs
123 -- (or possibly case etc if x demand is strict)
124 -- The binds are kept separate so they can be floated futher
128 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
129 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
133 data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
134 isOnceDem :: Bool -- True => used at most once
137 mkDem :: Demand -> Bool -> RhsDemand
138 mkDem strict once = RhsDemand (isStrict strict) once
140 mkDemTy :: Demand -> Type -> RhsDemand
141 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
143 isOnceTy :: Type -> Bool
144 isOnceTy ty = case tyUsg ty of
148 bdrDem :: Id -> RhsDemand
149 bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
151 safeDem, onceDem :: RhsDemand
152 safeDem = RhsDemand False False -- always safe to use this
153 onceDem = RhsDemand False True -- used at most once
156 No free/live variable information is pinned on in this pass; it's added
158 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
161 bOGUS_LVs :: StgLiveVars
162 bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
165 bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
169 topCoreBindsToStg :: UniqSupply -- name supply
170 -> [CoreBind] -- input
171 -> [StgBinding] -- output
173 topCoreBindsToStg us core_binds
174 = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
176 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
178 coreBindsToStg env [] = returnUs []
179 coreBindsToStg env (b:bs)
180 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
181 coreBindsToStg new_env bs `thenUs` \ new_bs ->
183 NonRecF bndr rhs dem floats
184 -> ASSERT2( not (isStrictDem dem) &&
185 not (isUnLiftedType (idType bndr)),
186 ppr b ) -- No top-level cases!
188 mkStgBinds floats rhs `thenUs` \ new_rhs ->
189 returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs)
190 -- Keep all the floats inside...
191 -- Some might be cases etc
192 -- We might want to revisit this decision
194 RecF prs -> returnUs (StgRec prs : new_bs)
195 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
200 %************************************************************************
202 \subsection[coreToStg-binds]{Converting bindings}
204 %************************************************************************
207 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
209 coreBindToStg top_lev env (NonRec binder rhs)
210 = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_rhs) ->
211 case (floats, stg_rhs) of
212 ([], StgApp var []) | not (isExportedId binder)
213 -> returnUs (NoBindF, extendVarEnv env binder var)
214 -- A trivial binding let x = y in ...
215 -- can arise if postSimplExpr floats a NoRep literal out
216 -- so it seems sensible to deal with it well.
217 -- But we don't want to discard exported things. They can
218 -- occur; e.g. an exported user binding f = g
220 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
221 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
225 coreBindToStg top_lev env (Rec pairs)
226 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
227 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
228 returnUs (RecF (binders' `zip` stg_rhss), env')
230 binders = map fst pairs
231 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) ->
232 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
233 -- NB: stg_expr' might still be a StgLam (and we want that)
234 returnUs (exprToRhs dem stg_expr')
240 %************************************************************************
242 \subsection[coreToStg-rhss]{Converting right hand sides}
244 %************************************************************************
247 exprToRhs :: RhsDemand -> StgExpr -> StgRhs
248 exprToRhs dem (StgLam _ bndrs body)
249 = ASSERT( not (null bndrs) )
254 ReEntrant -- binders is non-empty
259 We reject the following candidates for 'static constructor'dom:
261 - any dcon that takes a lit-lit as an arg.
262 - [Win32 DLLs only]: any dcon that is (or takes as arg)
263 that's living in a DLL.
265 These constraints are necessary to ensure that the code
266 generated in the end for the static constructors, which
267 live in the data segment, remain valid - i.e., it has to
268 be constant. For obvious reasons, that's hard to guarantee
269 with lit-lits. The second case of a constructor referring
270 to static closures hiding out in some DLL is an artifact
271 of the way Win32 DLLs handle global DLL variables. A (data)
272 symbol exported from a DLL has to be accessed through a
273 level of indirection at the site of use, so whereas
275 extern StgClosure y_closure;
276 extern StgClosure z_closure;
277 x = { ..., &y_closure, &z_closure };
279 is legal when the symbols are in scope at link-time, it is
280 not when y_closure is in a DLL. So, any potential static
281 closures that refers to stuff that's residing in a DLL
282 will be put in an (updateable) thunk instead.
284 An alternative strategy is to support the generation of
285 constructors (ala C++ static class constructors) which will
286 then be run at load time to fix up static closures.
288 exprToRhs dem (StgCon (DataCon con) args _)
290 all (not.is_lit_lit) args = StgRhsCon noCCS con args
292 is_dynamic = isDynCon con || any (isDynArg) args
294 is_lit_lit (StgVarArg _) = False
295 is_lit_lit (StgConArg x) =
297 Literal l -> isLitLitLit l
301 = StgRhsClosure noCCS -- No cost centre (ToDo?)
303 noSRT -- figure out later
305 (if isOnceDem dem then SingleEntry else Updatable)
306 -- HA! Paydirt for "dem"
310 isDynCon :: DataCon -> Bool
311 isDynCon con = isDynName (dataConName con)
313 isDynArg :: StgArg -> Bool
314 isDynArg (StgVarArg v) = isDynName (idName v)
315 isDynArg (StgConArg con) =
317 DataCon dc -> isDynCon dc
318 Literal l -> isLitLitLit l
321 isDynName :: Name -> Bool
323 not (isLocallyDefinedName nm) &&
324 isDynamicModule (nameModule nm)
328 %************************************************************************
330 \subsection[coreToStg-atoms{Converting atoms}
332 %************************************************************************
335 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
336 -- Arguments are all value arguments (tyargs already removed), paired with their demand
341 coreArgsToStg env (ad:ads)
342 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
343 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
344 returnUs (bs1 ++ bs2, a' : as')
347 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
348 -- This is where we arrange that a non-trivial argument is let-bound
350 coreArgToStg env (arg,dem)
351 = coreExprToStgFloat env arg dem `thenUs` \ (floats, arg') ->
353 StgCon con [] _ -> returnUs (floats, StgConArg con)
354 StgApp v [] -> returnUs (floats, StgVarArg v)
355 other -> newStgVar arg_ty `thenUs` \ v ->
356 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
358 arg_ty = coreExprType arg
362 %************************************************************************
364 \subsection[coreToStg-exprs]{Converting core expressions}
366 %************************************************************************
369 coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
370 coreExprToStg env expr dem
371 = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
372 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
376 %************************************************************************
378 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
380 %************************************************************************
383 coreExprToStgFloat :: StgEnv -> CoreExpr
385 -> UniqSM ([StgFloatBind], StgExpr)
386 -- Transform an expression to STG. The demand on the expression is
387 -- given by RhsDemand, and is solely used ot figure out the usage
388 -- of constructor args: if the constructor is used once, then so are
389 -- its arguments. The strictness info in RhsDemand isn't used.
391 -- The StgExpr returned *can* be an StgLam
397 coreExprToStgFloat env (Var var) dem
398 = returnUs ([], StgApp (stgLookup env var) [])
400 coreExprToStgFloat env (Let bind body) dem
401 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
402 coreExprToStgFloat new_env body dem `thenUs` \ (floats, stg_body) ->
403 returnUs (new_bind:floats, stg_body)
406 Covert core @scc@ expression directly to STG @scc@ expression.
409 coreExprToStgFloat env (Note (SCC cc) expr) dem
410 = coreExprToStg env expr dem `thenUs` \ stg_expr ->
411 returnUs ([], StgSCC cc stg_expr)
413 coreExprToStgFloat env (Note other_note expr) dem
414 = coreExprToStgFloat env expr dem
418 coreExprToStgFloat env expr@(Type _) dem
419 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
423 %************************************************************************
425 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
427 %************************************************************************
430 coreExprToStgFloat env expr@(Lam _ _) dem
432 expr_ty = coreExprType expr
433 (binders, body) = collectBinders expr
434 id_binders = filter isId binders
435 body_dem = trace "coreExprToStg: approximating body_dem in Lam"
438 if null id_binders then -- It was all type/usage binders; tossed
439 coreExprToStgFloat env body dem
441 -- At least some value binders
442 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
443 coreExprToStgFloat env' body body_dem `thenUs` \ (floats, stg_body) ->
444 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
447 StgLam ty lam_bndrs lam_body ->
448 -- If the body reduced to a lambda too, join them up
449 returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
452 -- Body didn't reduce to a lambda, so return one
453 returnUs ([], StgLam expr_ty binders' stg_body')
457 %************************************************************************
459 \subsubsection[coreToStg-applications]{Applications}
461 %************************************************************************
464 coreExprToStgFloat env expr@(App _ _) dem
466 (fun,rads,_,_) = collect_args expr
469 coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) ->
471 -- Now deal with the function
472 case (fun, stg_args) of
473 (Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
474 -- there are no arguments.
475 returnUs (arg_floats,
476 StgApp (stgLookup env fun_id) stg_args)
478 (non_var_fun, []) -> -- No value args, so recurse into the function
479 ASSERT( null arg_floats )
480 coreExprToStgFloat env non_var_fun dem
482 other -> -- A non-variable applied to things; better let-bind it.
483 newStgVar (coreExprType fun) `thenUs` \ fun_id ->
484 coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) ->
485 returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
486 StgApp fun_id stg_args)
489 -- Collect arguments and demands (*in reverse order*)
490 -- collect_args e = (f, args_w_demands, ty, stricts)
491 -- => e = f tys args, (i.e. args are just the value args)
493 -- stricts is the leftover demands of e on its further args
494 -- If stricts runs out, we zap all the demands in args_w_demands
495 -- because partial applications are lazy
497 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
499 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
500 in (the_fun,ads,ty,ss)
501 collect_args (Note InlineCall e) = collect_args e
502 collect_args (Note (TermUsg _) e) = collect_args e
504 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
505 in (the_fun,ads,applyTy fun_ty tyarg,ss)
506 collect_args (App fun arg)
508 [] -> -- Strictness info has run out
509 (the_fun, (arg, mkDemTy wwLazy arg_ty) : zap ads, res_ty, repeat wwLazy)
510 (ss1:ss_rest) -> -- Enough strictness info
511 (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
513 (the_fun, ads, fun_ty, ss) = collect_args fun
514 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
515 splitFunTy_maybe fun_ty
518 = (Var v, [], idType v, stricts)
520 stricts = case getIdStrictness v of
521 StrictnessInfo demands _ -> demands
522 other -> repeat wwLazy
524 collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
526 -- "zap" nukes the strictness info for a partial application
527 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
530 %************************************************************************
532 \subsubsection[coreToStg-con]{Constructors and primops}
534 %************************************************************************
536 For data constructors, the demand on an argument is the demand on the
537 constructor as a whole (see module UsageSPInf). For primops, the
538 demand is derived from the type of the primop.
540 If usage inference is off, we simply make all bindings updatable for
544 coreExprToStgFloat env expr@(Con con args) dem
546 (stricts,_) = conStrictness con
548 DEFAULT -> panic "coreExprToStgFloat: DEFAULT"
550 Literal _ -> ASSERT( null args' {-'cpp-} ) []
552 DataCon c -> repeat (isOnceDem dem)
553 -- HA! This is the sole reason we propagate
554 -- dem all the way down
556 PrimOp p -> let tyargs = map (\ (Type ty) -> ty) $
557 takeWhile isTypeArg args
558 (arg_tys,_) = primOpUsgTys p tyargs
559 in ASSERT( length arg_tys == length args' {-'cpp-} )
560 -- primops always fully applied, so == not >=
563 dems' = zipWith mkDem stricts onces
564 args' = filter isValArg args
566 coreArgsToStg env (zip args' dems') `thenUs` \ (arg_floats, stg_atoms) ->
568 -- YUK YUK: must unique if present
570 PrimOp (CCallOp (Right _) a b c) -> getUniqueUs `thenUs` \ u ->
571 returnUs (PrimOp (CCallOp (Right u) a b c))
575 returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
579 %************************************************************************
581 \subsubsection[coreToStg-cases]{Case expressions}
583 %************************************************************************
586 coreExprToStgFloat env (Case scrut bndr alts) dem
587 = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
588 newEvaldLocalId env bndr `thenUs` \ (env', bndr') ->
589 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
590 returnUs (binds, mkStgCase scrut' bndr' alts')
592 scrut_ty = idType bndr
593 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
595 alts_to_stg env (alts, deflt)
597 = default_to_stg env deflt `thenUs` \ deflt' ->
598 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
599 returnUs (StgPrimAlts scrut_ty alts' deflt')
602 = default_to_stg env deflt `thenUs` \ deflt' ->
603 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
604 returnUs (StgAlgAlts scrut_ty alts' deflt')
606 alg_alt_to_stg env (DataCon con, bs, rhs)
607 = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
608 returnUs (con, filter isId bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
609 -- NB the filter isId. Some of the binders may be
610 -- existential type variables, which STG doesn't care about
612 prim_alt_to_stg env (Literal lit, args, rhs)
613 = ASSERT( null args )
614 coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
615 returnUs (lit, stg_rhs)
617 default_to_stg env Nothing
618 = returnUs StgNoDefault
620 default_to_stg env (Just rhs)
621 = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
622 returnUs (StgBindDefault stg_rhs)
623 -- The binder is used for prim cases and not otherwise
624 -- (hack for old code gen)
628 %************************************************************************
630 \subsection[coreToStg-misc]{Miscellaneous helping functions}
632 %************************************************************************
634 There's not anything interesting we can ASSERT about \tr{var} if it
635 isn't in the StgEnv. (WDP 94/06)
638 stgLookup :: StgEnv -> Id -> Id
639 stgLookup env var = case (lookupVarEnv env var) of
646 newStgVar :: Type -> UniqSM Id
648 = getUniqueUs `thenUs` \ uniq ->
649 returnUs (mkSysLocal SLIT("stg") uniq ty)
653 -- we overload the demandInfo field of an Id to indicate whether the Id is definitely
654 -- evaluated or not (i.e. whether it is a case binder). This can be used to eliminate
655 -- some redundant cases (c.f. dataToTag# above).
657 newEvaldLocalId env id
658 = getUniqueUs `thenUs` \ uniq ->
660 id' = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
661 new_env = extendVarEnv env id id'
663 returnUs (new_env, id')
666 newLocalId TopLevel env id
668 -- Don't clone top-level binders. MkIface relies on their
669 -- uniques staying the same, so it can snaffle IdInfo off the
670 -- STG ids to put in interface files.
672 newLocalId NotTopLevel env id
673 = -- Local binder, give it a new unique Id.
674 getUniqueUs `thenUs` \ uniq ->
676 id' = setIdUnique id uniq
677 new_env = extendVarEnv env id id'
679 returnUs (new_env, id')
681 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
682 newLocalIds top_lev env []
684 newLocalIds top_lev env (b:bs)
685 = newLocalId top_lev env b `thenUs` \ (env', b') ->
686 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
687 returnUs (env'', b':bs')
692 -- Stg doesn't have a lambda *expression*,
693 deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
694 deStgLam expr = returnUs expr
696 mkStgLamExpr ty bndrs body
697 = ASSERT( not (null bndrs) )
698 newStgVar ty `thenUs` \ fn ->
699 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
701 lam_closure = StgRhsClosure noCCS
705 ReEntrant -- binders is non-empty
709 mkStgBinds :: [StgFloatBind]
710 -> StgExpr -- *Can* be a StgLam
711 -> UniqSM StgExpr -- *Can* be a StgLam
713 mkStgBinds [] body = returnUs body
714 mkStgBinds (b:bs) body
715 = deStgLam body `thenUs` \ body' ->
718 go [] body = returnUs body
719 go (b:bs) body = go bs body `thenUs` \ body' ->
722 -- The 'body' arg of mkStgBind can't be a StgLam
723 mkStgBind NoBindF body = returnUs body
724 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
726 mkStgBind (NonRecF bndr rhs dem floats) body
728 -- We shouldn't get let or case of the form v=w
730 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
731 (mk_stg_let bndr rhs dem floats body)
732 other -> mk_stg_let bndr rhs dem floats body
734 mk_stg_let bndr rhs dem floats body
736 | isUnLiftedType bndr_ty -- Use a case/PrimAlts
737 = ASSERT( not (isUnboxedTupleType bndr_ty) )
739 mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
743 -- Strict let with WHNF rhs
745 StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
747 -- Lazy let with WHNF rhs; float until we find a strict binding
749 (floats_out, floats_in) = splitFloats floats
751 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
752 mkStgBinds floats_out $
753 StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
755 | otherwise -- Not WHNF
757 -- Strict let with non-WHNF rhs
759 mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
761 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
762 mkStgBinds floats rhs `thenUs` \ new_rhs ->
763 returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
766 bndr_ty = idType bndr
767 is_strict = isStrictDem dem
768 is_whnf = case rhs of
773 -- Split at the first strict binding
774 splitFloats fs@(NonRecF _ _ dem _ : _)
775 | isStrictDem dem = ([], fs)
777 splitFloats (f : fs) = case splitFloats fs of
778 (fs_out, fs_in) -> (f : fs_out, fs_in)
780 splitFloats [] = ([], [])
783 mkStgCase scrut bndr alts
784 = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
785 -- We should never find
786 -- case (\x->e) of { ... }
787 -- The simplifier eliminates such things
788 StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts