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 ( exprType )
21 import SimplUtils ( findDefault )
22 import CostCentre ( noCCS )
23 import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId,
24 externallyVisibleId, setIdUnique, idName,
25 idDemandInfo, idArity, setIdType, idFlavour
27 import Var ( Var, varType, modifyIdInfo )
28 import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) )
29 import UsageSPUtils ( primOpUsgTys )
30 import DataCon ( DataCon, dataConName, dataConWrapId )
31 import Demand ( Demand, isStrict, wwStrict, wwLazy )
32 import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
33 import Literal ( Literal(..) )
35 import PrimOp ( PrimOp(..), CCall(..), CCallTarget(..), primOpUsg )
36 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
37 UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
38 splitRepFunTys, mkFunTys
40 import TysPrim ( intPrimTy )
41 import UniqSupply -- all of it, really
42 import Util ( lengthExceeds )
43 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
44 import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
45 import UniqSet ( emptyUniqSet )
51 *************************************************
52 *************** OVERVIEW *********************
53 *************************************************
56 The business of this pass is to convert Core to Stg. On the way it
57 does some important transformations:
59 1. We discard type lambdas and applications. In so doing we discard
60 "trivial" bindings such as
62 where t1, t2 are types
64 2. We get the program into "A-normal form". In particular:
66 f E ==> let x = E in f x
67 OR ==> case E of x -> f x
69 where E is a non-trivial expression.
70 Which transformation is used depends on whether f is strict or not.
71 [Previously the transformation to case used to be done by the
72 simplifier, but it's better done here. It does mean that f needs
73 to have its strictness info correct!.]
75 Similarly, convert any unboxed let's into cases.
76 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
77 right up to this point.]
79 3. We clone all local binders. The code generator uses the uniques to
80 name chunks of code for thunks, so it's important that the names used
81 are globally unique, not simply not-in-scope, which is all that
82 the simplifier ensures.
87 * We don't pin on correct arities any more, because they can be mucked up
88 by the lambda lifter. In particular, the lambda lifter can take a local
89 letrec-bound variable and make it a lambda argument, which shouldn't have
90 an arity. So SetStgVarInfo sets arities now.
92 * We do *not* pin on the correct free/live var info; that's done later.
93 Instead we use bOGUS_LVS and _FVS as a placeholder.
95 [Quite a bit of stuff that used to be here has moved
96 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
99 %************************************************************************
101 \subsection[coreToStg-programs]{Converting a core program and core bindings}
103 %************************************************************************
105 March 98: We keep a small environment to give all locally bound
106 Names new unique ids, since the code generator assumes that binders
107 are unique across a module. (Simplifier doesn't maintain this
108 invariant any longer.)
110 A binder to be floated out becomes an @StgFloatBind@.
113 type StgEnv = IdEnv Id
115 data StgFloatBind = NoBindF
116 | RecF [(Id, StgRhs)]
119 StgExpr -- *Can* be a StgLam
123 -- The interesting one is the NonRecF
124 -- NonRecF x rhs demand binds
126 -- x = let binds in rhs
127 -- (or possibly case etc if x demand is strict)
128 -- The binds are kept separate so they can be floated futher
132 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
133 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
137 data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
138 isOnceDem :: Bool -- True => used at most once
141 mkDem :: Demand -> Bool -> RhsDemand
142 mkDem strict once = RhsDemand (isStrict strict) once
144 mkDemTy :: Demand -> Type -> RhsDemand
145 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
147 isOnceTy :: Type -> Bool
151 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
156 UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
158 bdrDem :: Id -> RhsDemand
159 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
161 safeDem, onceDem :: RhsDemand
162 safeDem = RhsDemand False False -- always safe to use this
163 onceDem = RhsDemand False True -- used at most once
166 No free/live variable information is pinned on in this pass; it's added
168 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
170 When printing out the Stg we need non-bottom values in these
174 bOGUS_LVs :: StgLiveVars
175 bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
176 | otherwise =panic "bOGUS_LVs"
179 bOGUS_FVs | opt_D_verbose_stg2stg = []
180 | otherwise = panic "bOGUS_FVs"
184 topCoreBindsToStg :: UniqSupply -- name supply
185 -> [CoreBind] -- input
186 -> [StgBinding] -- output
188 topCoreBindsToStg us core_binds
189 = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
191 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
193 coreBindsToStg env [] = returnUs []
194 coreBindsToStg env (b:bs)
195 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
196 coreBindsToStg new_env bs `thenUs` \ new_bs ->
198 NonRecF bndr rhs dem floats
199 -> ASSERT2( not (isStrictDem dem) &&
200 not (isUnLiftedType (idType bndr)),
201 ppr b ) -- No top-level cases!
203 mkStgBinds floats rhs `thenUs` \ new_rhs ->
204 returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
206 -- Keep all the floats inside...
207 -- Some might be cases etc
208 -- We might want to revisit this decision
210 RecF prs -> returnUs (StgRec prs : new_bs)
211 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
216 %************************************************************************
218 \subsection[coreToStg-binds]{Converting bindings}
220 %************************************************************************
223 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
225 coreBindToStg top_lev env (NonRec binder rhs)
226 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
227 case (floats, stg_rhs) of
228 ([], StgApp var []) | not (isExportedId binder)
229 -> returnUs (NoBindF, extendVarEnv env binder var)
230 -- A trivial binding let x = y in ...
231 -- can arise if postSimplExpr floats a NoRep literal out
232 -- so it seems sensible to deal with it well.
233 -- But we don't want to discard exported things. They can
234 -- occur; e.g. an exported user binding f = g
236 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
237 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
242 coreBindToStg top_lev env (Rec pairs)
243 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
244 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
245 returnUs (RecF (binders' `zip` stg_rhss), env')
247 binders = map fst pairs
248 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
249 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
250 -- NB: stg_expr' might still be a StgLam (and we want that)
251 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
255 %************************************************************************
257 \subsection[coreToStg-rhss]{Converting right hand sides}
259 %************************************************************************
262 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
263 exprToRhs dem _ (StgLam _ bndrs body)
264 = ASSERT( not (null bndrs) )
269 ReEntrant -- binders is non-empty
274 We reject the following candidates for 'static constructor'dom:
276 - any dcon that takes a lit-lit as an arg.
277 - [Win32 DLLs only]: any dcon that resides in a DLL
278 (or takes as arg something that is.)
280 These constraints are necessary to ensure that the code
281 generated in the end for the static constructors, which
282 live in the data segment, remain valid - i.e., it has to
283 be constant. For obvious reasons, that's hard to guarantee
284 with lit-lits. The second case of a constructor referring
285 to static closures hiding out in some DLL is an artifact
286 of the way Win32 DLLs handle global DLL variables. A (data)
287 symbol exported from a DLL has to be accessed through a
288 level of indirection at the site of use, so whereas
290 extern StgClosure y_closure;
291 extern StgClosure z_closure;
292 x = { ..., &y_closure, &z_closure };
294 is legal when the symbols are in scope at link-time, it is
295 not when y_closure is in a DLL. So, any potential static
296 closures that refers to stuff that's residing in a DLL
297 will be put in an (updateable) thunk instead.
299 An alternative strategy is to support the generation of
300 constructors (ala C++ static class constructors) which will
301 then be run at load time to fix up static closures.
303 exprToRhs dem toplev (StgConApp con args)
304 | isNotTopLevel toplev || not (isDllConApp con args)
305 -- isDllConApp checks for LitLit args too
306 = StgRhsCon noCCS con args
310 StgRhsClosure noCCS -- No cost centre (ToDo?)
312 noSRT -- figure out later
318 upd = if isOnceDem dem then SingleEntry else Updatable
319 -- HA! Paydirt for "dem"
323 %************************************************************************
325 \subsection[coreToStg-atoms{Converting atoms}
327 %************************************************************************
330 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
331 -- Arguments are all value arguments (tyargs already removed), paired with their demand
336 coreArgsToStg env (ad:ads)
337 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
338 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
339 returnUs (bs1 ++ bs2, a' : as')
342 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
343 -- This is where we arrange that a non-trivial argument is let-bound
345 coreArgToStg env (arg,dem)
346 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
348 StgApp v [] -> returnUs (floats, StgVarArg v)
349 StgLit lit -> returnUs (floats, StgLitArg lit)
351 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
352 -- A nullary constructor can be replaced with
353 -- a ``call'' to its wrapper
355 other -> newStgVar arg_ty `thenUs` \ v ->
356 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
358 arg_ty = exprType arg
362 %************************************************************************
364 \subsection[coreToStg-exprs]{Converting core expressions}
366 %************************************************************************
369 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
370 coreExprToStg env expr
371 = coreExprToStgFloat env expr `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
384 -> UniqSM ([StgFloatBind], StgExpr)
385 -- Transform an expression to STG. The 'floats' are
386 -- any bindings we had to create for function arguments.
392 coreExprToStgFloat env (Var var)
393 = mkStgApp env var [] (idType var) `thenUs` \ app ->
396 coreExprToStgFloat env (Lit lit)
397 = returnUs ([], StgLit lit)
399 coreExprToStgFloat env (Let bind body)
400 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
401 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
402 returnUs (new_bind:floats, stg_body)
405 Convert core @scc@ expression directly to STG @scc@ expression.
408 coreExprToStgFloat env (Note (SCC cc) expr)
409 = coreExprToStg env expr `thenUs` \ stg_expr ->
410 returnUs ([], StgSCC cc stg_expr)
412 coreExprToStgFloat env (Note other_note expr)
413 = coreExprToStgFloat env expr
417 coreExprToStgFloat env expr@(Type _)
418 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
422 %************************************************************************
424 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
426 %************************************************************************
429 coreExprToStgFloat env expr@(Lam _ _)
431 expr_ty = exprType expr
432 (binders, body) = collectBinders expr
433 id_binders = filter isId binders
435 if null id_binders then -- It was all type/usage binders; tossed
436 coreExprToStgFloat env body
438 -- At least some value binders
439 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
440 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
441 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
444 StgLam ty lam_bndrs lam_body ->
445 -- If the body reduced to a lambda too, join them up
446 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
449 -- Body didn't reduce to a lambda, so return one
450 returnUs ([], mkStgLam expr_ty binders' stg_body')
454 %************************************************************************
456 \subsubsection[coreToStg-applications]{Applications}
458 %************************************************************************
461 coreExprToStgFloat env expr@(App _ _)
463 (fun,rads,ty,ss) = collect_args expr
465 final_ads | null ss = ads
466 | otherwise = zap ads -- Too few args to satisfy strictness info
467 -- so we have to ignore all the strictness info
468 -- e.g. + (error "urk")
469 -- Here, we can't evaluate the arg strictly,
470 -- because this partial application might be seq'd
472 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
474 -- Now deal with the function
475 case (fun, stg_args) of
476 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
477 -- there are no arguments.
478 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
479 returnUs (arg_floats, app)
481 (non_var_fun, []) -> -- No value args, so recurse into the function
482 ASSERT( null arg_floats )
483 coreExprToStgFloat env non_var_fun
485 other -> -- A non-variable applied to things; better let-bind it.
486 newStgVar (exprType fun) `thenUs` \ fn_id ->
487 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
488 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
489 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
493 -- Collect arguments and demands (*in reverse order*)
494 -- collect_args e = (f, args_w_demands, ty, stricts)
495 -- => e = f tys args, (i.e. args are just the value args)
497 -- stricts is the leftover demands of e on its further args
498 -- If stricts runs out, we zap all the demands in args_w_demands
499 -- because partial applications are lazy
501 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
503 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
504 in (the_fun,ads,ty,ss)
505 collect_args (Note InlineCall e) = collect_args e
506 collect_args (Note (TermUsg _) e) = collect_args e
508 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
509 in (the_fun,ads,applyTy fun_ty tyarg,ss)
510 collect_args (App fun arg)
511 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
513 (ss1, ss_rest) = case ss of
514 (ss1:ss_rest) -> (ss1, ss_rest)
516 (the_fun, ads, fun_ty, ss) = collect_args fun
517 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
518 splitFunTy_maybe fun_ty
521 = (Var v, [], idType v, stricts)
523 stricts = case idStrictness v of
524 StrictnessInfo demands _ -> demands
525 other -> repeat wwLazy
527 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
529 -- "zap" nukes the strictness info for a partial application
530 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
534 %************************************************************************
536 \subsubsection[coreToStg-cases]{Case expressions}
538 %************************************************************************
541 coreExprToStgFloat env (Case scrut bndr alts)
542 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
543 newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
544 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
545 returnUs (binds, mkStgCase scrut' bndr' alts')
547 scrut_ty = idType bndr
548 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
550 alts_to_stg env (alts, deflt)
552 = default_to_stg env deflt `thenUs` \ deflt' ->
553 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
554 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
557 = default_to_stg env deflt `thenUs` \ deflt' ->
558 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
559 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
561 alg_alt_to_stg env (DataAlt con, bs, rhs)
562 = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
563 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
564 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
565 -- NB the filter isId. Some of the binders may be
566 -- existential type variables, which STG doesn't care about
568 prim_alt_to_stg env (LitAlt lit, args, rhs)
569 = ASSERT( null args )
570 coreExprToStg env rhs `thenUs` \ stg_rhs ->
571 returnUs (lit, stg_rhs)
573 default_to_stg env Nothing
574 = returnUs StgNoDefault
576 default_to_stg env (Just rhs)
577 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
578 returnUs (StgBindDefault stg_rhs)
579 -- The binder is used for prim cases and not otherwise
580 -- (hack for old code gen)
584 %************************************************************************
586 \subsection[coreToStg-misc]{Miscellaneous helping functions}
588 %************************************************************************
590 There's not anything interesting we can ASSERT about \tr{var} if it
591 isn't in the StgEnv. (WDP 94/06)
595 newStgVar :: Type -> UniqSM Id
597 = getUniqueUs `thenUs` \ uniq ->
599 returnUs (mkSysLocal SLIT("stg") uniq ty)
603 newLocalId TopLevel env id
604 -- Don't clone top-level binders. MkIface relies on their
605 -- uniques staying the same, so it can snaffle IdInfo off the
606 -- STG ids to put in interface files.
613 returnUs (env, mkVanillaId name ty)
616 newLocalId NotTopLevel env id
617 = -- Local binder, give it a new unique Id.
618 getUniqueUs `thenUs` \ uniq ->
622 new_id = mkVanillaId (setNameUnique name uniq) ty
623 new_env = extendVarEnv env id new_id
627 returnUs (new_env, new_id)
629 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
630 newLocalIds top_lev env []
632 newLocalIds top_lev env (b:bs)
633 = newLocalId top_lev env b `thenUs` \ (env', b') ->
634 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
635 returnUs (env'', b':bs')
639 %************************************************************************
641 \subsection{Building STG syn}
643 %************************************************************************
646 mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
647 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
648 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
650 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
651 -- The type is the type of the entire application
652 mkStgApp env fn args ty
653 = case idFlavour fn_alias of
655 -> saturate fn_alias args ty $ \ args' ty' ->
656 returnUs (StgConApp dc args')
658 PrimOpId (CCallOp (CCall (DynamicTarget _) a b c))
659 -- Sigh...make a guaranteed unique name for a dynamic ccall
660 -> saturate fn_alias args ty $ \ args' ty' ->
661 getUniqueUs `thenUs` \ u ->
662 returnUs (StgPrimApp (CCallOp (CCall (DynamicTarget u) a b c)) args' ty')
665 -> saturate fn_alias args ty $ \ args' ty' ->
666 returnUs (StgPrimApp op args' ty')
668 other -> returnUs (StgApp fn_alias args)
671 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
675 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
676 -- The type should be the type of (id args)
677 saturate fn args ty thing_inside
678 | excess_arity == 0 -- Saturated, so nothing to do
679 = thing_inside args ty
681 | otherwise -- An unsaturated constructor or primop; eta expand it
682 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
683 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
684 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
685 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
686 returnUs (StgLam ty arg_vars body)
688 fn_arity = idArity fn
689 excess_arity = fn_arity - length args
690 (arg_tys, res_ty) = splitRepFunTys ty
691 extra_arg_tys = take excess_arity arg_tys
692 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
696 -- Stg doesn't have a lambda *expression*
697 deStgLam (StgLam ty bndrs body)
698 -- Try for eta reduction
699 = ASSERT( not (null bndrs) )
701 Just e -> -- Eta succeeded
704 Nothing -> -- Eta failed, so let-bind the lambda
705 newStgVar ty `thenUs` \ fn ->
706 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
708 lam_closure = StgRhsClosure noCCS
712 ReEntrant -- binders is non-empty
717 | n_remaining >= 0 &&
718 and (zipWith ok bndrs last_args) &&
719 notInExpr bndrs remaining_expr
720 = Just remaining_expr
722 remaining_expr = StgApp f remaining_args
723 (remaining_args, last_args) = splitAt n_remaining args
724 n_remaining = length args - length bndrs
726 eta (StgLet bind@(StgNonRec b r) body)
727 | notInRhs bndrs r = case eta body of
728 Just e -> Just (StgLet bind e)
733 ok bndr (StgVarArg arg) = bndr == arg
734 ok bndr other = False
736 deStgLam expr = returnUs expr
739 --------------------------------------------------
740 notInExpr :: [Id] -> StgExpr -> Bool
741 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
742 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
743 notInExpr vs other = False -- Safe
745 notInRhs :: [Id] -> StgRhs -> Bool
746 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
747 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
748 -- Conservative: we could delete the binders from vs, but
749 -- cloning means this will never help
751 notInArgs :: [Id] -> [StgArg] -> Bool
752 notInArgs vs args = all ok args
754 ok (StgVarArg v) = notInId vs v
755 ok (StgLitArg l) = True
757 notInId :: [Id] -> Id -> Bool
758 notInId vs v = not (v `elem` vs)
762 mkStgBinds :: [StgFloatBind]
763 -> StgExpr -- *Can* be a StgLam
764 -> UniqSM StgExpr -- *Can* be a StgLam
766 mkStgBinds [] body = returnUs body
767 mkStgBinds (b:bs) body
768 = deStgLam body `thenUs` \ body' ->
771 go [] body = returnUs body
772 go (b:bs) body = go bs body `thenUs` \ body' ->
775 -- The 'body' arg of mkStgBind can't be a StgLam
776 mkStgBind NoBindF body = returnUs body
777 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
779 mkStgBind (NonRecF bndr rhs dem floats) body
781 -- We shouldn't get let or case of the form v=w
783 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
784 (mk_stg_let bndr rhs dem floats body)
785 other -> mk_stg_let bndr rhs dem floats body
787 mk_stg_let bndr rhs dem floats body
789 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
790 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
792 mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
796 -- Strict let with WHNF rhs
798 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
800 -- Lazy let with WHNF rhs; float until we find a strict binding
802 (floats_out, floats_in) = splitFloats floats
804 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
805 mkStgBinds floats_out $
806 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
808 | otherwise -- Not WHNF
810 -- Strict let with non-WHNF rhs
812 mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
814 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
815 mkStgBinds floats rhs `thenUs` \ new_rhs ->
816 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
819 bndr_rep_ty = repType (idType bndr)
820 is_strict = isStrictDem dem
821 is_whnf = case rhs of
822 StgConApp _ _ -> True
826 -- Split at the first strict binding
827 splitFloats fs@(NonRecF _ _ dem _ : _)
828 | isStrictDem dem = ([], fs)
830 splitFloats (f : fs) = case splitFloats fs of
831 (fs_out, fs_in) -> (f : fs_out, fs_in)
833 splitFloats [] = ([], [])
840 First, two special cases. We mangle cases involving
844 Up to this point, seq# will appear like this:
850 This code comes from an unfolding for 'seq' in Prelude.hs.
851 The 0# branch is purely to bamboozle the strictness analyser.
852 For example, if <stuff> is strict in x, and there was no seqError#
853 branch, the strictness analyser would conclude that the whole expression
854 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
856 Now that the evaluation order is safe, we translate this into
861 This used to be done in the post-simplification phase, but we need
862 unfoldings involving seq# to appear unmangled in the interface file,
863 hence we do this mangling here.
865 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
877 fork# isn't handled like this - it's an explicit IO operation now.
878 The reason is that fork# returns a ThreadId#, which gets in the
879 way of the above scheme. And anyway, IO is the only guaranteed
880 way to enforce ordering --SDM.
884 -- Discard alernatives in case (par# ..) of
885 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
886 (StgPrimAlts ty _ deflt@(StgBindDefault _))
887 = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt)
889 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
890 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
891 = mkStgCase scrut_expr new_bndr (StgAlgAlts scrut_ty [] (StgBindDefault rhs))
893 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
894 | otherwise = StgAlgAlts scrut_ty [] deflt
895 scrut_ty = stgArgType scrut
896 new_bndr = setIdType bndr scrut_ty
897 -- NB: SeqOp :: forall a. a -> Int#
898 -- So bndr has type Int#
899 -- But now we are going to scrutinise the SeqOp's argument directly,
900 -- so we must change the type of the case binder to match that
901 -- of the argument expression e.
903 scrut_expr = case scrut of
904 StgVarArg v -> StgApp v []
905 -- Others should not happen because
906 -- seq of a value should have disappeared
907 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
909 mkStgCase scrut bndr alts
910 = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
911 -- We should never find
912 -- case (\x->e) of { ... }
913 -- The simplifier eliminates such things
914 StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts