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 PprCore ( {- instance Outputable Bind/Expr -} )
21 import CoreUtils ( exprType )
22 import SimplUtils ( findDefault )
23 import CostCentre ( noCCS )
24 import Id ( Id, mkSysLocal, idType, idStrictness, idUnique, isExportedId, mkVanillaId,
25 externallyVisibleId, setIdUnique, idName,
26 idDemandInfo, idArity, setIdType, idFlavour
28 import Var ( Var, varType, modifyIdInfo )
29 import IdInfo ( setDemandInfo, StrictnessInfo(..), IdFlavour(..) )
30 import UsageSPUtils ( primOpUsgTys )
31 import DataCon ( DataCon, dataConName, dataConWrapId )
32 import Demand ( Demand, isStrict, wwStrict, wwLazy )
33 import Name ( Name, nameModule, isLocallyDefinedName, setNameUnique )
34 import Literal ( Literal(..) )
36 import PrimOp ( PrimOp(..), setCCallUnique, primOpUsg )
37 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
38 UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType,
39 splitRepFunTys, mkFunTys
41 import TysPrim ( intPrimTy )
42 import UniqSupply -- all of it, really
43 import Util ( lengthExceeds )
44 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
45 import CmdLineOpts ( opt_D_verbose_stg2stg, opt_UsageSPOn )
46 import UniqSet ( emptyUniqSet )
52 *************************************************
53 *************** OVERVIEW *********************
54 *************************************************
57 The business of this pass is to convert Core to Stg. On the way it
58 does some important transformations:
60 1. We discard type lambdas and applications. In so doing we discard
61 "trivial" bindings such as
63 where t1, t2 are types
65 2. We get the program into "A-normal form". In particular:
67 f E ==> let x = E in f x
68 OR ==> case E of x -> f x
70 where E is a non-trivial expression.
71 Which transformation is used depends on whether f is strict or not.
72 [Previously the transformation to case used to be done by the
73 simplifier, but it's better done here. It does mean that f needs
74 to have its strictness info correct!.]
76 Similarly, convert any unboxed let's into cases.
77 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
78 right up to this point.]
80 3. We clone all local binders. The code generator uses the uniques to
81 name chunks of code for thunks, so it's important that the names used
82 are globally unique, not simply not-in-scope, which is all that
83 the simplifier ensures.
88 * We don't pin on correct arities any more, because they can be mucked up
89 by the lambda lifter. In particular, the lambda lifter can take a local
90 letrec-bound variable and make it a lambda argument, which shouldn't have
91 an arity. So SetStgVarInfo sets arities now.
93 * We do *not* pin on the correct free/live var info; that's done later.
94 Instead we use bOGUS_LVS and _FVS as a placeholder.
96 [Quite a bit of stuff that used to be here has moved
97 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
100 %************************************************************************
102 \subsection[coreToStg-programs]{Converting a core program and core bindings}
104 %************************************************************************
106 March 98: We keep a small environment to give all locally bound
107 Names new unique ids, since the code generator assumes that binders
108 are unique across a module. (Simplifier doesn't maintain this
109 invariant any longer.)
111 A binder to be floated out becomes an @StgFloatBind@.
114 type StgEnv = IdEnv Id
116 data StgFloatBind = NoBindF
117 | RecF [(Id, StgRhs)]
120 StgExpr -- *Can* be a StgLam
124 -- The interesting one is the NonRecF
125 -- NonRecF x rhs demand binds
127 -- x = let binds in rhs
128 -- (or possibly case etc if x demand is strict)
129 -- The binds are kept separate so they can be floated futher
133 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
134 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
138 data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
139 isOnceDem :: Bool -- True => used at most once
142 mkDem :: Demand -> Bool -> RhsDemand
143 mkDem strict once = RhsDemand (isStrict strict) once
145 mkDemTy :: Demand -> Type -> RhsDemand
146 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
148 isOnceTy :: Type -> Bool
152 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
157 UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
159 bdrDem :: Id -> RhsDemand
160 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
162 safeDem, onceDem :: RhsDemand
163 safeDem = RhsDemand False False -- always safe to use this
164 onceDem = RhsDemand False True -- used at most once
167 No free/live variable information is pinned on in this pass; it's added
169 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
171 When printing out the Stg we need non-bottom values in these
175 bOGUS_LVs :: StgLiveVars
176 bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
177 | otherwise =panic "bOGUS_LVs"
180 bOGUS_FVs | opt_D_verbose_stg2stg = []
181 | otherwise = panic "bOGUS_FVs"
185 topCoreBindsToStg :: UniqSupply -- name supply
186 -> [CoreBind] -- input
187 -> [StgBinding] -- output
189 topCoreBindsToStg us core_binds
190 = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
192 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
194 coreBindsToStg env [] = returnUs []
195 coreBindsToStg env (b:bs)
196 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
197 coreBindsToStg new_env bs `thenUs` \ new_bs ->
199 NonRecF bndr rhs dem floats
200 -> ASSERT2( not (isStrictDem dem) &&
201 not (isUnLiftedType (idType bndr)),
202 ppr b ) -- No top-level cases!
204 mkStgBinds floats rhs `thenUs` \ new_rhs ->
205 returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
207 -- Keep all the floats inside...
208 -- Some might be cases etc
209 -- We might want to revisit this decision
211 RecF prs -> returnUs (StgRec prs : new_bs)
212 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
217 %************************************************************************
219 \subsection[coreToStg-binds]{Converting bindings}
221 %************************************************************************
224 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
226 coreBindToStg top_lev env (NonRec binder rhs)
227 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
228 case (floats, stg_rhs) of
229 ([], StgApp var []) | not (isExportedId binder)
230 -> returnUs (NoBindF, extendVarEnv env binder var)
231 -- A trivial binding let x = y in ...
232 -- can arise if postSimplExpr floats a NoRep literal out
233 -- so it seems sensible to deal with it well.
234 -- But we don't want to discard exported things. They can
235 -- occur; e.g. an exported user binding f = g
237 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
238 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
243 coreBindToStg top_lev env (Rec pairs)
244 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
245 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
246 returnUs (RecF (binders' `zip` stg_rhss), env')
248 binders = map fst pairs
249 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
250 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
251 -- NB: stg_expr' might still be a StgLam (and we want that)
252 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
256 %************************************************************************
258 \subsection[coreToStg-rhss]{Converting right hand sides}
260 %************************************************************************
263 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
264 exprToRhs dem _ (StgLam _ bndrs body)
265 = ASSERT( not (null bndrs) )
270 ReEntrant -- binders is non-empty
275 We reject the following candidates for 'static constructor'dom:
277 - any dcon that takes a lit-lit as an arg.
278 - [Win32 DLLs only]: any dcon that resides in a DLL
279 (or takes as arg something that is.)
281 These constraints are necessary to ensure that the code
282 generated in the end for the static constructors, which
283 live in the data segment, remain valid - i.e., it has to
284 be constant. For obvious reasons, that's hard to guarantee
285 with lit-lits. The second case of a constructor referring
286 to static closures hiding out in some DLL is an artifact
287 of the way Win32 DLLs handle global DLL variables. A (data)
288 symbol exported from a DLL has to be accessed through a
289 level of indirection at the site of use, so whereas
291 extern StgClosure y_closure;
292 extern StgClosure z_closure;
293 x = { ..., &y_closure, &z_closure };
295 is legal when the symbols are in scope at link-time, it is
296 not when y_closure is in a DLL. So, any potential static
297 closures that refers to stuff that's residing in a DLL
298 will be put in an (updateable) thunk instead.
300 An alternative strategy is to support the generation of
301 constructors (ala C++ static class constructors) which will
302 then be run at load time to fix up static closures.
304 exprToRhs dem toplev (StgConApp con args)
305 | isNotTopLevel toplev || not (isDllConApp con args)
306 -- isDllConApp checks for LitLit args too
307 = StgRhsCon noCCS con args
311 StgRhsClosure noCCS -- No cost centre (ToDo?)
313 noSRT -- figure out later
319 upd = if isOnceDem dem then SingleEntry else Updatable
320 -- HA! Paydirt for "dem"
324 %************************************************************************
326 \subsection[coreToStg-atoms{Converting atoms}
328 %************************************************************************
331 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
332 -- Arguments are all value arguments (tyargs already removed), paired with their demand
337 coreArgsToStg env (ad:ads)
338 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
339 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
340 returnUs (bs1 ++ bs2, a' : as')
343 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
344 -- This is where we arrange that a non-trivial argument is let-bound
346 coreArgToStg env (arg,dem)
347 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
349 StgApp v [] -> returnUs (floats, StgVarArg v)
350 StgLit lit -> returnUs (floats, StgLitArg lit)
352 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
353 -- A nullary constructor can be replaced with
354 -- a ``call'' to its wrapper
356 other -> newStgVar arg_ty `thenUs` \ v ->
357 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
359 arg_ty = exprType arg
363 %************************************************************************
365 \subsection[coreToStg-exprs]{Converting core expressions}
367 %************************************************************************
370 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
371 coreExprToStg env expr
372 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
373 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
377 %************************************************************************
379 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
381 %************************************************************************
384 coreExprToStgFloat :: StgEnv -> CoreExpr
385 -> UniqSM ([StgFloatBind], StgExpr)
386 -- Transform an expression to STG. The 'floats' are
387 -- any bindings we had to create for function arguments.
393 coreExprToStgFloat env (Var var)
394 = mkStgApp env var [] (idType var) `thenUs` \ app ->
397 coreExprToStgFloat env (Lit lit)
398 = returnUs ([], StgLit lit)
400 coreExprToStgFloat env (Let bind body)
401 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
402 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
403 returnUs (new_bind:floats, stg_body)
406 Convert core @scc@ expression directly to STG @scc@ expression.
409 coreExprToStgFloat env (Note (SCC cc) expr)
410 = coreExprToStg env expr `thenUs` \ stg_expr ->
411 returnUs ([], StgSCC cc stg_expr)
413 coreExprToStgFloat env (Note other_note expr)
414 = coreExprToStgFloat env expr
418 coreExprToStgFloat env expr@(Type _)
419 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
423 %************************************************************************
425 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
427 %************************************************************************
430 coreExprToStgFloat env expr@(Lam _ _)
432 expr_ty = exprType expr
433 (binders, body) = collectBinders expr
434 id_binders = filter isId binders
436 if null id_binders then -- It was all type/usage binders; tossed
437 coreExprToStgFloat env body
439 -- At least some value binders
440 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
441 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
442 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
445 StgLam ty lam_bndrs lam_body ->
446 -- If the body reduced to a lambda too, join them up
447 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
450 -- Body didn't reduce to a lambda, so return one
451 returnUs ([], mkStgLam expr_ty binders' stg_body')
455 %************************************************************************
457 \subsubsection[coreToStg-applications]{Applications}
459 %************************************************************************
462 coreExprToStgFloat env expr@(App _ _)
464 (fun,rads,ty,ss) = collect_args expr
466 final_ads | null ss = ads
467 | otherwise = zap ads -- Too few args to satisfy strictness info
468 -- so we have to ignore all the strictness info
469 -- e.g. + (error "urk")
470 -- Here, we can't evaluate the arg strictly,
471 -- because this partial application might be seq'd
473 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
475 -- Now deal with the function
476 case (fun, stg_args) of
477 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
478 -- there are no arguments.
479 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
480 returnUs (arg_floats, app)
482 (non_var_fun, []) -> -- No value args, so recurse into the function
483 ASSERT( null arg_floats )
484 coreExprToStgFloat env non_var_fun
486 other -> -- A non-variable applied to things; better let-bind it.
487 newStgVar (exprType fun) `thenUs` \ fn_id ->
488 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
489 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
490 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
494 -- Collect arguments and demands (*in reverse order*)
495 -- collect_args e = (f, args_w_demands, ty, stricts)
496 -- => e = f tys args, (i.e. args are just the value args)
498 -- stricts is the leftover demands of e on its further args
499 -- If stricts runs out, we zap all the demands in args_w_demands
500 -- because partial applications are lazy
502 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
504 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
505 in (the_fun,ads,ty,ss)
506 collect_args (Note InlineCall e) = collect_args e
507 collect_args (Note (TermUsg _) e) = collect_args e
509 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
510 in (the_fun,ads,applyTy fun_ty tyarg,ss)
511 collect_args (App fun arg)
512 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
514 (ss1, ss_rest) = case ss of
515 (ss1:ss_rest) -> (ss1, ss_rest)
517 (the_fun, ads, fun_ty, ss) = collect_args fun
518 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
519 splitFunTy_maybe fun_ty
522 = (Var v, [], idType v, stricts)
524 stricts = case idStrictness v of
525 StrictnessInfo demands _ -> demands
526 other -> repeat wwLazy
528 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
530 -- "zap" nukes the strictness info for a partial application
531 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
535 %************************************************************************
537 \subsubsection[coreToStg-cases]{Case expressions}
539 %************************************************************************
542 coreExprToStgFloat env (Case scrut bndr alts)
543 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
544 newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
545 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
546 mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
547 returnUs (binds, expr')
549 scrut_ty = idType bndr
550 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
552 alts_to_stg env (alts, deflt)
554 = default_to_stg env deflt `thenUs` \ deflt' ->
555 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
556 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
559 = default_to_stg env deflt `thenUs` \ deflt' ->
560 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
561 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
563 alg_alt_to_stg env (DataAlt con, bs, rhs)
564 = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
565 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
566 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
567 -- NB the filter isId. Some of the binders may be
568 -- existential type variables, which STG doesn't care about
570 prim_alt_to_stg env (LitAlt lit, args, rhs)
571 = ASSERT( null args )
572 coreExprToStg env rhs `thenUs` \ stg_rhs ->
573 returnUs (lit, stg_rhs)
575 default_to_stg env Nothing
576 = returnUs StgNoDefault
578 default_to_stg env (Just rhs)
579 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
580 returnUs (StgBindDefault stg_rhs)
581 -- The binder is used for prim cases and not otherwise
582 -- (hack for old code gen)
586 %************************************************************************
588 \subsection[coreToStg-misc]{Miscellaneous helping functions}
590 %************************************************************************
592 There's not anything interesting we can ASSERT about \tr{var} if it
593 isn't in the StgEnv. (WDP 94/06)
597 newStgVar :: Type -> UniqSM Id
599 = getUniqueUs `thenUs` \ uniq ->
601 returnUs (mkSysLocal SLIT("stg") uniq ty)
605 newLocalId TopLevel env id
606 -- Don't clone top-level binders. MkIface relies on their
607 -- uniques staying the same, so it can snaffle IdInfo off the
608 -- STG ids to put in interface files.
615 returnUs (env, mkVanillaId name ty)
618 newLocalId NotTopLevel env id
619 = -- Local binder, give it a new unique Id.
620 getUniqueUs `thenUs` \ uniq ->
624 new_id = mkVanillaId (setNameUnique name uniq) ty
625 new_env = extendVarEnv env id new_id
629 returnUs (new_env, new_id)
631 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
632 newLocalIds top_lev env []
634 newLocalIds top_lev env (b:bs)
635 = newLocalId top_lev env b `thenUs` \ (env', b') ->
636 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
637 returnUs (env'', b':bs')
641 %************************************************************************
643 \subsection{Building STG syn}
645 %************************************************************************
648 mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
649 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
650 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
652 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
653 -- The type is the type of the entire application
654 mkStgApp env fn args ty
655 = case idFlavour fn_alias of
657 -> saturate fn_alias args ty $ \ args' ty' ->
658 returnUs (StgConApp dc args')
660 PrimOpId (CCallOp ccall)
661 -- Sigh...make a guaranteed unique name for a dynamic ccall
662 -- Done here, not earlier, because it's a code-gen thing
663 -> saturate fn_alias args ty $ \ args' ty' ->
664 returnUs (StgPrimApp (CCallOp ccall') args' ty')
666 ccall' = setCCallUnique ccall (idUnique fn)
667 -- The particular unique doesn't matter
670 -> saturate fn_alias args ty $ \ args' ty' ->
671 returnUs (StgPrimApp op args' ty')
673 other -> returnUs (StgApp fn_alias args)
676 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
680 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
681 -- The type should be the type of (id args)
682 saturate fn args ty thing_inside
683 | excess_arity == 0 -- Saturated, so nothing to do
684 = thing_inside args ty
686 | otherwise -- An unsaturated constructor or primop; eta expand it
687 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
688 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
689 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
690 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
691 returnUs (StgLam ty arg_vars body)
693 fn_arity = idArity fn
694 excess_arity = fn_arity - length args
695 (arg_tys, res_ty) = splitRepFunTys ty
696 extra_arg_tys = take excess_arity arg_tys
697 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
701 -- Stg doesn't have a lambda *expression*
702 deStgLam (StgLam ty bndrs body)
703 -- Try for eta reduction
704 = ASSERT( not (null bndrs) )
706 Just e -> -- Eta succeeded
709 Nothing -> -- Eta failed, so let-bind the lambda
710 newStgVar ty `thenUs` \ fn ->
711 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
713 lam_closure = StgRhsClosure noCCS
717 ReEntrant -- binders is non-empty
722 | n_remaining >= 0 &&
723 and (zipWith ok bndrs last_args) &&
724 notInExpr bndrs remaining_expr
725 = Just remaining_expr
727 remaining_expr = StgApp f remaining_args
728 (remaining_args, last_args) = splitAt n_remaining args
729 n_remaining = length args - length bndrs
731 eta (StgLet bind@(StgNonRec b r) body)
732 | notInRhs bndrs r = case eta body of
733 Just e -> Just (StgLet bind e)
738 ok bndr (StgVarArg arg) = bndr == arg
739 ok bndr other = False
741 deStgLam expr = returnUs expr
744 --------------------------------------------------
745 notInExpr :: [Id] -> StgExpr -> Bool
746 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
747 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
748 notInExpr vs other = False -- Safe
750 notInRhs :: [Id] -> StgRhs -> Bool
751 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
752 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
753 -- Conservative: we could delete the binders from vs, but
754 -- cloning means this will never help
756 notInArgs :: [Id] -> [StgArg] -> Bool
757 notInArgs vs args = all ok args
759 ok (StgVarArg v) = notInId vs v
760 ok (StgLitArg l) = True
762 notInId :: [Id] -> Id -> Bool
763 notInId vs v = not (v `elem` vs)
767 mkStgBinds :: [StgFloatBind]
768 -> StgExpr -- *Can* be a StgLam
769 -> UniqSM StgExpr -- *Can* be a StgLam
771 mkStgBinds [] body = returnUs body
772 mkStgBinds (b:bs) body
773 = deStgLam body `thenUs` \ body' ->
776 go [] body = returnUs body
777 go (b:bs) body = go bs body `thenUs` \ body' ->
780 -- The 'body' arg of mkStgBind can't be a StgLam
781 mkStgBind NoBindF body = returnUs body
782 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
784 mkStgBind (NonRecF bndr rhs dem floats) body
786 -- We shouldn't get let or case of the form v=w
788 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
789 (mk_stg_let bndr rhs dem floats body)
790 other -> mk_stg_let bndr rhs dem floats body
792 mk_stg_let bndr rhs dem floats body
794 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
795 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
796 mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
797 mkStgBinds floats expr'
801 -- Strict let with WHNF rhs
803 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
805 -- Lazy let with WHNF rhs; float until we find a strict binding
807 (floats_out, floats_in) = splitFloats floats
809 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
810 mkStgBinds floats_out $
811 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
813 | otherwise -- Not WHNF
815 -- Strict let with non-WHNF rhs
816 mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
817 mkStgBinds floats expr'
819 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
820 mkStgBinds floats rhs `thenUs` \ new_rhs ->
821 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
824 bndr_rep_ty = repType (idType bndr)
825 is_strict = isStrictDem dem
826 is_whnf = case rhs of
827 StgConApp _ _ -> True
831 -- Split at the first strict binding
832 splitFloats fs@(NonRecF _ _ dem _ : _)
833 | isStrictDem dem = ([], fs)
835 splitFloats (f : fs) = case splitFloats fs of
836 (fs_out, fs_in) -> (f : fs_out, fs_in)
838 splitFloats [] = ([], [])
845 First, two special cases. We mangle cases involving
849 Up to this point, seq# will appear like this:
855 This code comes from an unfolding for 'seq' in Prelude.hs.
856 The 0# branch is purely to bamboozle the strictness analyser.
857 For example, if <stuff> is strict in x, and there was no seqError#
858 branch, the strictness analyser would conclude that the whole expression
859 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
861 Now that the evaluation order is safe, we translate this into
866 This used to be done in the post-simplification phase, but we need
867 unfoldings involving seq# to appear unmangled in the interface file,
868 hence we do this mangling here.
870 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
882 fork# isn't handled like this - it's an explicit IO operation now.
883 The reason is that fork# returns a ThreadId#, which gets in the
884 way of the above scheme. And anyway, IO is the only guaranteed
885 way to enforce ordering --SDM.
889 -- Discard alernatives in case (par# ..) of
890 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
891 (StgPrimAlts ty _ deflt@(StgBindDefault _))
892 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt))
894 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
895 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
896 = mkStgCase scrut_expr new_bndr new_alts
898 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
899 | otherwise = StgAlgAlts scrut_ty [] deflt
900 scrut_ty = stgArgType scrut
901 new_bndr = setIdType bndr scrut_ty
902 -- NB: SeqOp :: forall a. a -> Int#
903 -- So bndr has type Int#
904 -- But now we are going to scrutinise the SeqOp's argument directly,
905 -- so we must change the type of the case binder to match that
906 -- of the argument expression e.
908 scrut_expr = case scrut of
909 StgVarArg v -> StgApp v []
910 -- Others should not happen because
911 -- seq of a value should have disappeared
912 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
914 mkStgCase scrut bndr alts
915 = deStgLam scrut `thenUs` \ scrut' ->
916 -- It is (just) possible to get a lambda as a srutinee here
917 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
918 -- gives: case ...Bool == Int->Int... of
919 -- True -> case coerce Bool (\x -> + 1 x) of
923 -- The True branch of the outer case will never happen, of course.
925 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)