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, isExportedId,
24 mkVanillaId, idName, idDemandInfo, idArity, setIdType,
27 import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
28 import DataCon ( dataConWrapId )
29 import Demand ( Demand, isStrict, wwLazy )
30 import Name ( setNameUnique )
32 import PrimOp ( PrimOp(..), setCCallUnique )
33 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
34 applyTy, repType, seqType,
35 splitRepFunTys, mkFunTys,
36 uaUTy, usOnce, usMany, isTyVarTy
38 import UniqSupply -- all of it, really
39 import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
40 import UniqSet ( emptyUniqSet )
46 *************************************************
47 *************** OVERVIEW *********************
48 *************************************************
51 The business of this pass is to convert Core to Stg. On the way it
52 does some important transformations:
54 1. We discard type lambdas and applications. In so doing we discard
55 "trivial" bindings such as
57 where t1, t2 are types
59 2. We get the program into "A-normal form". In particular:
61 f E ==> let x = E in f x
62 OR ==> case E of x -> f x
64 where E is a non-trivial expression.
65 Which transformation is used depends on whether f is strict or not.
66 [Previously the transformation to case used to be done by the
67 simplifier, but it's better done here. It does mean that f needs
68 to have its strictness info correct!.]
70 Similarly, convert any unboxed let's into cases.
71 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
72 right up to this point.]
74 3. We clone all local binders. The code generator uses the uniques to
75 name chunks of code for thunks, so it's important that the names used
76 are globally unique, not simply not-in-scope, which is all that
77 the simplifier ensures.
82 * We don't pin on correct arities any more, because they can be mucked up
83 by the lambda lifter. In particular, the lambda lifter can take a local
84 letrec-bound variable and make it a lambda argument, which shouldn't have
85 an arity. So SetStgVarInfo sets arities now.
87 * We do *not* pin on the correct free/live var info; that's done later.
88 Instead we use bOGUS_LVS and _FVS as a placeholder.
90 [Quite a bit of stuff that used to be here has moved
91 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
94 %************************************************************************
96 \subsection[coreToStg-programs]{Converting a core program and core bindings}
98 %************************************************************************
100 March 98: We keep a small environment to give all locally bound
101 Names new unique ids, since the code generator assumes that binders
102 are unique across a module. (Simplifier doesn't maintain this
103 invariant any longer.)
105 A binder to be floated out becomes an @StgFloatBind@.
108 type StgEnv = IdEnv Id
110 data StgFloatBind = NoBindF
111 | RecF [(Id, StgRhs)]
114 StgExpr -- *Can* be a StgLam
118 -- The interesting one is the NonRecF
119 -- NonRecF x rhs demand binds
121 -- x = let binds in rhs
122 -- (or possibly case etc if x demand is strict)
123 -- The binds are kept separate so they can be floated futher
127 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
128 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
132 data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
133 isOnceDem :: Bool -- True => used at most once
136 mkDem :: Demand -> Bool -> RhsDemand
137 mkDem strict once = RhsDemand (isStrict strict) once
139 mkDemTy :: Demand -> Type -> RhsDemand
140 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
142 isOnceTy :: Type -> Bool
146 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
151 once | u == usOnce = True
152 | u == usMany = False
153 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
155 bdrDem :: Id -> RhsDemand
156 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
158 safeDem, onceDem :: RhsDemand
159 safeDem = RhsDemand False False -- always safe to use this
160 onceDem = RhsDemand False True -- used at most once
163 No free/live variable information is pinned on in this pass; it's added
165 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
167 When printing out the Stg we need non-bottom values in these
171 bOGUS_LVs :: StgLiveVars
172 bOGUS_LVs = emptyUniqSet
179 topCoreBindsToStg :: UniqSupply -- name supply
180 -> [CoreBind] -- input
181 -> [StgBinding] -- output
183 topCoreBindsToStg us core_binds
184 = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
186 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
188 coreBindsToStg env [] = returnUs []
189 coreBindsToStg env (b:bs)
190 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
191 coreBindsToStg new_env bs `thenUs` \ new_bs ->
193 NonRecF bndr rhs dem floats
194 -> ASSERT2( not (isStrictDem dem) &&
195 not (isUnLiftedType (idType bndr)),
196 ppr b ) -- No top-level cases!
198 mkStgBinds floats rhs `thenUs` \ new_rhs ->
199 returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
201 -- Keep all the floats inside...
202 -- Some might be cases etc
203 -- We might want to revisit this decision
205 RecF prs -> returnUs (StgRec prs : new_bs)
206 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
211 %************************************************************************
213 \subsection[coreToStg-binds]{Converting bindings}
215 %************************************************************************
218 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
220 coreBindToStg top_lev env (NonRec binder rhs)
221 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
222 case (floats, stg_rhs) of
223 ([], StgApp var []) | not (isExportedId binder)
224 -> returnUs (NoBindF, extendVarEnv env binder var)
225 -- A trivial binding let x = y in ...
226 -- can arise if postSimplExpr floats a NoRep literal out
227 -- so it seems sensible to deal with it well.
228 -- But we don't want to discard exported things. They can
229 -- occur; e.g. an exported user binding f = g
231 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
232 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
237 coreBindToStg top_lev env (Rec pairs)
238 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
239 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
240 returnUs (RecF (binders' `zip` stg_rhss), env')
242 binders = map fst pairs
243 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
244 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
245 -- NB: stg_expr' might still be a StgLam (and we want that)
246 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
250 %************************************************************************
252 \subsection[coreToStg-rhss]{Converting right hand sides}
254 %************************************************************************
257 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
258 exprToRhs dem _ (StgLam _ bndrs body)
259 = ASSERT( not (null bndrs) )
264 ReEntrant -- binders is non-empty
269 We reject the following candidates for 'static constructor'dom:
271 - any dcon that takes a lit-lit as an arg.
272 - [Win32 DLLs only]: any dcon that resides in a DLL
273 (or takes as arg something that is.)
275 These constraints are necessary to ensure that the code
276 generated in the end for the static constructors, which
277 live in the data segment, remain valid - i.e., it has to
278 be constant. For obvious reasons, that's hard to guarantee
279 with lit-lits. The second case of a constructor referring
280 to static closures hiding out in some DLL is an artifact
281 of the way Win32 DLLs handle global DLL variables. A (data)
282 symbol exported from a DLL has to be accessed through a
283 level of indirection at the site of use, so whereas
285 extern StgClosure y_closure;
286 extern StgClosure z_closure;
287 x = { ..., &y_closure, &z_closure };
289 is legal when the symbols are in scope at link-time, it is
290 not when y_closure is in a DLL. So, any potential static
291 closures that refers to stuff that's residing in a DLL
292 will be put in an (updateable) thunk instead.
294 An alternative strategy is to support the generation of
295 constructors (ala C++ static class constructors) which will
296 then be run at load time to fix up static closures.
298 exprToRhs dem toplev (StgConApp con args)
299 | isNotTopLevel toplev || not (isDllConApp con args)
300 -- isDllConApp checks for LitLit args too
301 = StgRhsCon noCCS con args
303 exprToRhs dem toplev expr
305 StgRhsClosure noCCS -- No cost centre (ToDo?)
307 noSRT -- figure out later
313 upd = if isOnceDem dem
314 then (if isNotTopLevel toplev
315 then SingleEntry -- HA! Paydirt for "dem"
318 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
322 -- For now we forbid SingleEntry CAFs; they tickle the
323 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
324 -- and I don't understand why. There's only one SE_CAF (well,
325 -- only one that tickled a great gaping bug in an earlier attempt
326 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
327 -- specifically Main.lvl6 in spectral/cryptarithm2.
328 -- So no great loss. KSW 2000-07.
332 %************************************************************************
334 \subsection[coreToStg-atoms{Converting atoms}
336 %************************************************************************
339 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
340 -- Arguments are all value arguments (tyargs already removed), paired with their demand
345 coreArgsToStg env (ad:ads)
346 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
347 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
348 returnUs (bs1 ++ bs2, a' : as')
351 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
352 -- This is where we arrange that a non-trivial argument is let-bound
354 coreArgToStg env (arg,dem)
355 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
357 StgApp v [] -> returnUs (floats, StgVarArg v)
358 StgLit lit -> returnUs (floats, StgLitArg lit)
360 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
361 -- A nullary constructor can be replaced with
362 -- a ``call'' to its wrapper
364 other -> newStgVar arg_ty `thenUs` \ v ->
365 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
367 arg_ty = exprType arg
371 %************************************************************************
373 \subsection[coreToStg-exprs]{Converting core expressions}
375 %************************************************************************
378 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
379 coreExprToStg env expr
380 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
381 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
385 %************************************************************************
387 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
389 %************************************************************************
392 coreExprToStgFloat :: StgEnv -> CoreExpr
393 -> UniqSM ([StgFloatBind], StgExpr)
394 -- Transform an expression to STG. The 'floats' are
395 -- any bindings we had to create for function arguments.
401 coreExprToStgFloat env (Var var)
402 = mkStgApp env var [] (idType var) `thenUs` \ app ->
405 coreExprToStgFloat env (Lit lit)
406 = returnUs ([], StgLit lit)
408 coreExprToStgFloat env (Let bind body)
409 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
410 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
411 returnUs (new_bind:floats, stg_body)
414 Convert core @scc@ expression directly to STG @scc@ expression.
417 coreExprToStgFloat env (Note (SCC cc) expr)
418 = coreExprToStg env expr `thenUs` \ stg_expr ->
419 returnUs ([], StgSCC cc stg_expr)
421 coreExprToStgFloat env (Note other_note expr)
422 = coreExprToStgFloat env expr
426 coreExprToStgFloat env expr@(Type _)
427 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
431 %************************************************************************
433 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
435 %************************************************************************
438 coreExprToStgFloat env expr@(Lam _ _)
440 expr_ty = exprType expr
441 (binders, body) = collectBinders expr
442 id_binders = filter isId binders
444 if null id_binders then -- It was all type binders; tossed
445 coreExprToStgFloat env body
447 -- At least some value binders
448 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
449 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
450 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
453 StgLam ty lam_bndrs lam_body ->
454 -- If the body reduced to a lambda too, join them up
455 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
458 -- Body didn't reduce to a lambda, so return one
459 returnUs ([], mkStgLam expr_ty binders' stg_body')
463 %************************************************************************
465 \subsubsection[coreToStg-applications]{Applications}
467 %************************************************************************
470 coreExprToStgFloat env expr@(App _ _)
472 (fun,rads,ty,ss) = collect_args expr
474 final_ads | null ss = ads
475 | otherwise = zap ads -- Too few args to satisfy strictness info
476 -- so we have to ignore all the strictness info
477 -- e.g. + (error "urk")
478 -- Here, we can't evaluate the arg strictly,
479 -- because this partial application might be seq'd
481 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
483 -- Now deal with the function
484 case (fun, stg_args) of
485 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
486 -- there are no arguments.
487 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
488 returnUs (arg_floats, app)
490 (non_var_fun, []) -> -- No value args, so recurse into the function
491 ASSERT( null arg_floats )
492 coreExprToStgFloat env non_var_fun
494 other -> -- A non-variable applied to things; better let-bind it.
495 newStgVar (exprType fun) `thenUs` \ fn_id ->
496 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
497 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
498 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
502 -- Collect arguments and demands (*in reverse order*)
503 -- collect_args e = (f, args_w_demands, ty, stricts)
504 -- => e = f tys args, (i.e. args are just the value args)
506 -- stricts is the leftover demands of e on its further args
507 -- If stricts runs out, we zap all the demands in args_w_demands
508 -- because partial applications are lazy
510 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
512 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
513 in (the_fun,ads,ty,ss)
514 collect_args (Note InlineCall e) = collect_args e
516 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
517 in (the_fun,ads,applyTy fun_ty tyarg,ss)
518 collect_args (App fun arg)
519 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
521 (ss1, ss_rest) = case ss of
522 (ss1:ss_rest) -> (ss1, ss_rest)
524 (the_fun, ads, fun_ty, ss) = collect_args fun
525 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
526 splitFunTy_maybe fun_ty
529 = (Var v, [], idType v, stricts)
531 stricts = case idStrictness v of
532 StrictnessInfo demands _ -> demands
533 other -> repeat wwLazy
535 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
537 -- "zap" nukes the strictness info for a partial application
538 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
542 %************************************************************************
544 \subsubsection[coreToStg-cases]{Case expressions}
546 %************************************************************************
549 coreExprToStgFloat env (Case scrut bndr alts)
550 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
551 newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
552 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
553 mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
554 returnUs (binds, expr')
556 scrut_ty = idType bndr
557 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
559 alts_to_stg env (alts, deflt)
561 = default_to_stg env deflt `thenUs` \ deflt' ->
562 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
563 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
566 = default_to_stg env deflt `thenUs` \ deflt' ->
567 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
568 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
570 alg_alt_to_stg env (DataAlt con, bs, rhs)
571 = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
572 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
573 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
574 -- NB the filter isId. Some of the binders may be
575 -- existential type variables, which STG doesn't care about
577 prim_alt_to_stg env (LitAlt lit, args, rhs)
578 = ASSERT( null args )
579 coreExprToStg env rhs `thenUs` \ stg_rhs ->
580 returnUs (lit, stg_rhs)
582 default_to_stg env Nothing
583 = returnUs StgNoDefault
585 default_to_stg env (Just rhs)
586 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
587 returnUs (StgBindDefault stg_rhs)
588 -- The binder is used for prim cases and not otherwise
589 -- (hack for old code gen)
593 %************************************************************************
595 \subsection[coreToStg-misc]{Miscellaneous helping functions}
597 %************************************************************************
599 There's not anything interesting we can ASSERT about \tr{var} if it
600 isn't in the StgEnv. (WDP 94/06)
604 newStgVar :: Type -> UniqSM Id
606 = getUniqueUs `thenUs` \ uniq ->
608 returnUs (mkSysLocal SLIT("stg") uniq ty)
612 newLocalId TopLevel env id
613 -- Don't clone top-level binders. MkIface relies on their
614 -- uniques staying the same, so it can snaffle IdInfo off the
615 -- STG ids to put in interface files.
622 returnUs (env, mkVanillaId name ty)
625 newLocalId NotTopLevel env id
626 = -- Local binder, give it a new unique Id.
627 getUniqueUs `thenUs` \ uniq ->
631 new_id = mkVanillaId (setNameUnique name uniq) ty
632 new_env = extendVarEnv env id new_id
636 returnUs (new_env, new_id)
638 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
639 newLocalIds top_lev env []
641 newLocalIds top_lev env (b:bs)
642 = newLocalId top_lev env b `thenUs` \ (env', b') ->
643 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
644 returnUs (env'', b':bs')
648 %************************************************************************
650 \subsection{Building STG syn}
652 %************************************************************************
655 mkStgAlgAlts ty alts deflt = seqType ty `seq` StgAlgAlts ty alts deflt
656 mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
657 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
659 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
660 -- The type is the type of the entire application
661 mkStgApp env fn args ty
662 = case idFlavour fn_alias of
664 -> saturate fn_alias args ty $ \ args' ty' ->
665 returnUs (StgConApp dc args')
667 PrimOpId (CCallOp ccall)
668 -- Sigh...make a guaranteed unique name for a dynamic ccall
669 -- Done here, not earlier, because it's a code-gen thing
670 -> saturate fn_alias args ty $ \ args' ty' ->
671 getUniqueUs `thenUs` \ uniq ->
672 let ccall' = setCCallUnique ccall uniq in
673 returnUs (StgPrimApp (CCallOp ccall') args' ty')
677 -> saturate fn_alias args ty $ \ args' ty' ->
678 returnUs (StgPrimApp op args' ty')
680 other -> returnUs (StgApp fn_alias args)
683 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
687 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
688 -- The type should be the type of (id args)
689 saturate fn args ty thing_inside
690 | excess_arity == 0 -- Saturated, so nothing to do
691 = thing_inside args ty
693 | otherwise -- An unsaturated constructor or primop; eta expand it
694 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
695 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
696 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
697 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
698 returnUs (StgLam ty arg_vars body)
700 fn_arity = idArity fn
701 excess_arity = fn_arity - length args
702 (arg_tys, res_ty) = splitRepFunTys ty
703 extra_arg_tys = take excess_arity arg_tys
704 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
708 -- Stg doesn't have a lambda *expression*
709 deStgLam (StgLam ty bndrs body)
710 -- Try for eta reduction
711 = ASSERT( not (null bndrs) )
713 Just e -> -- Eta succeeded
716 Nothing -> -- Eta failed, so let-bind the lambda
717 newStgVar ty `thenUs` \ fn ->
718 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
720 lam_closure = StgRhsClosure noCCS
724 ReEntrant -- binders is non-empty
729 | n_remaining >= 0 &&
730 and (zipWith ok bndrs last_args) &&
731 notInExpr bndrs remaining_expr
732 = Just remaining_expr
734 remaining_expr = StgApp f remaining_args
735 (remaining_args, last_args) = splitAt n_remaining args
736 n_remaining = length args - length bndrs
738 eta (StgLet bind@(StgNonRec b r) body)
739 | notInRhs bndrs r = case eta body of
740 Just e -> Just (StgLet bind e)
745 ok bndr (StgVarArg arg) = bndr == arg
746 ok bndr other = False
748 deStgLam expr = returnUs expr
751 --------------------------------------------------
752 notInExpr :: [Id] -> StgExpr -> Bool
753 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
754 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
755 notInExpr vs other = False -- Safe
757 notInRhs :: [Id] -> StgRhs -> Bool
758 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
759 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
760 -- Conservative: we could delete the binders from vs, but
761 -- cloning means this will never help
763 notInArgs :: [Id] -> [StgArg] -> Bool
764 notInArgs vs args = all ok args
766 ok (StgVarArg v) = notInId vs v
767 ok (StgLitArg l) = True
769 notInId :: [Id] -> Id -> Bool
770 notInId vs v = not (v `elem` vs)
774 mkStgBinds :: [StgFloatBind]
775 -> StgExpr -- *Can* be a StgLam
776 -> UniqSM StgExpr -- *Can* be a StgLam
778 mkStgBinds [] body = returnUs body
779 mkStgBinds (b:bs) body
780 = deStgLam body `thenUs` \ body' ->
783 go [] body = returnUs body
784 go (b:bs) body = go bs body `thenUs` \ body' ->
787 -- The 'body' arg of mkStgBind can't be a StgLam
788 mkStgBind NoBindF body = returnUs body
789 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
791 mkStgBind (NonRecF bndr rhs dem floats) body
793 -- We shouldn't get let or case of the form v=w
795 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
796 (mk_stg_let bndr rhs dem floats body)
797 other -> mk_stg_let bndr rhs dem floats body
799 mk_stg_let bndr rhs dem floats body
801 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
802 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
803 mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
804 mkStgBinds floats expr'
808 -- Strict let with WHNF rhs
810 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
812 -- Lazy let with WHNF rhs; float until we find a strict binding
814 (floats_out, floats_in) = splitFloats floats
816 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
817 mkStgBinds floats_out $
818 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
820 | otherwise -- Not WHNF
822 -- Strict let with non-WHNF rhs
823 mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
824 mkStgBinds floats expr'
826 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
827 mkStgBinds floats rhs `thenUs` \ new_rhs ->
828 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
831 bndr_rep_ty = repType (idType bndr)
832 is_strict = isStrictDem dem
833 is_whnf = case rhs of
834 StgConApp _ _ -> True
838 -- Split at the first strict binding
839 splitFloats fs@(NonRecF _ _ dem _ : _)
840 | isStrictDem dem = ([], fs)
842 splitFloats (f : fs) = case splitFloats fs of
843 (fs_out, fs_in) -> (f : fs_out, fs_in)
845 splitFloats [] = ([], [])
852 First, two special cases. We mangle cases involving
856 Up to this point, seq# will appear like this:
862 This code comes from an unfolding for 'seq' in Prelude.hs.
863 The 0# branch is purely to bamboozle the strictness analyser.
864 For example, if <stuff> is strict in x, and there was no seqError#
865 branch, the strictness analyser would conclude that the whole expression
866 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
868 Now that the evaluation order is safe, we translate this into
873 This used to be done in the post-simplification phase, but we need
874 unfoldings involving seq# to appear unmangled in the interface file,
875 hence we do this mangling here.
877 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
889 fork# isn't handled like this - it's an explicit IO operation now.
890 The reason is that fork# returns a ThreadId#, which gets in the
891 way of the above scheme. And anyway, IO is the only guaranteed
892 way to enforce ordering --SDM.
896 -- Discard alernatives in case (par# ..) of
897 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
898 (StgPrimAlts ty _ deflt@(StgBindDefault _))
899 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts ty [] deflt))
901 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
902 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
903 = mkStgCase scrut_expr new_bndr new_alts
905 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) StgPrimAlts scrut_ty [] deflt
906 | otherwise = StgAlgAlts scrut_ty [] deflt
907 scrut_ty = stgArgType scrut
908 new_bndr = setIdType bndr scrut_ty
909 -- NB: SeqOp :: forall a. a -> Int#
910 -- So bndr has type Int#
911 -- But now we are going to scrutinise the SeqOp's argument directly,
912 -- so we must change the type of the case binder to match that
913 -- of the argument expression e.
915 scrut_expr = case scrut of
916 StgVarArg v -> StgApp v []
917 -- Others should not happen because
918 -- seq of a value should have disappeared
919 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
921 mkStgCase scrut bndr alts
922 = deStgLam scrut `thenUs` \ scrut' ->
923 -- It is (just) possible to get a lambda as a srutinee here
924 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
925 -- gives: case ...Bool == Int->Int... of
926 -- True -> case coerce Bool (\x -> + 1 x) of
930 -- The True branch of the outer case will never happen, of course.
932 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)