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, dataConTyCon )
29 import TyCon ( isAlgTyCon )
30 import Demand ( Demand, isStrict, wwLazy )
31 import Name ( setNameUnique )
33 import PrimOp ( PrimOp(..), setCCallUnique )
34 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
35 applyTy, repType, seqType, splitTyConApp_maybe,
36 splitRepFunTys, mkFunTys,
37 uaUTy, usOnce, usMany, isTyVarTy
39 import UniqSupply -- all of it, really
40 import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
41 import UniqSet ( emptyUniqSet )
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
147 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
152 once | u == usOnce = True
153 | u == usMany = False
154 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
156 bdrDem :: Id -> RhsDemand
157 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
159 safeDem, onceDem :: RhsDemand
160 safeDem = RhsDemand False False -- always safe to use this
161 onceDem = RhsDemand False True -- used at most once
164 No free/live variable information is pinned on in this pass; it's added
166 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
168 When printing out the Stg we need non-bottom values in these
172 bOGUS_LVs :: StgLiveVars
173 bOGUS_LVs = emptyUniqSet
180 topCoreBindsToStg :: UniqSupply -- name supply
181 -> [CoreBind] -- input
182 -> [StgBinding] -- output
184 topCoreBindsToStg us core_binds
185 = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
187 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
189 coreBindsToStg env [] = returnUs []
190 coreBindsToStg env (b:bs)
191 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
192 coreBindsToStg new_env bs `thenUs` \ new_bs ->
194 NonRecF bndr rhs dem floats
195 -> ASSERT2( not (isStrictDem dem) &&
196 not (isUnLiftedType (idType bndr)),
197 ppr b ) -- No top-level cases!
199 mkStgBinds floats rhs `thenUs` \ new_rhs ->
200 returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
202 -- Keep all the floats inside...
203 -- Some might be cases etc
204 -- We might want to revisit this decision
206 RecF prs -> returnUs (StgRec prs : new_bs)
207 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
212 %************************************************************************
214 \subsection[coreToStg-binds]{Converting bindings}
216 %************************************************************************
219 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
221 coreBindToStg top_lev env (NonRec binder rhs)
222 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
223 case (floats, stg_rhs) of
224 ([], StgApp var []) | not (isExportedId binder)
225 -> returnUs (NoBindF, extendVarEnv env binder var)
226 -- A trivial binding let x = y in ...
227 -- can arise if postSimplExpr floats a NoRep literal out
228 -- so it seems sensible to deal with it well.
229 -- But we don't want to discard exported things. They can
230 -- occur; e.g. an exported user binding f = g
232 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
233 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
238 coreBindToStg top_lev env (Rec pairs)
239 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
240 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
241 returnUs (RecF (binders' `zip` stg_rhss), env')
243 binders = map fst pairs
244 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
245 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
246 -- NB: stg_expr' might still be a StgLam (and we want that)
247 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
251 %************************************************************************
253 \subsection[coreToStg-rhss]{Converting right hand sides}
255 %************************************************************************
258 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
259 exprToRhs dem _ (StgLam _ bndrs body)
260 = ASSERT( not (null bndrs) )
265 ReEntrant -- binders is non-empty
270 We reject the following candidates for 'static constructor'dom:
272 - any dcon that takes a lit-lit as an arg.
273 - [Win32 DLLs only]: any dcon that resides in a DLL
274 (or takes as arg something that is.)
276 These constraints are necessary to ensure that the code
277 generated in the end for the static constructors, which
278 live in the data segment, remain valid - i.e., it has to
279 be constant. For obvious reasons, that's hard to guarantee
280 with lit-lits. The second case of a constructor referring
281 to static closures hiding out in some DLL is an artifact
282 of the way Win32 DLLs handle global DLL variables. A (data)
283 symbol exported from a DLL has to be accessed through a
284 level of indirection at the site of use, so whereas
286 extern StgClosure y_closure;
287 extern StgClosure z_closure;
288 x = { ..., &y_closure, &z_closure };
290 is legal when the symbols are in scope at link-time, it is
291 not when y_closure is in a DLL. So, any potential static
292 closures that refers to stuff that's residing in a DLL
293 will be put in an (updateable) thunk instead.
295 An alternative strategy is to support the generation of
296 constructors (ala C++ static class constructors) which will
297 then be run at load time to fix up static closures.
299 exprToRhs dem toplev (StgConApp con args)
300 | isNotTopLevel toplev || not (isDllConApp con args)
301 -- isDllConApp checks for LitLit args too
302 = StgRhsCon noCCS con args
304 exprToRhs dem toplev expr
306 StgRhsClosure noCCS -- No cost centre (ToDo?)
308 noSRT -- figure out later
314 upd = if isOnceDem dem
315 then (if isNotTopLevel toplev
316 then SingleEntry -- HA! Paydirt for "dem"
319 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
323 -- For now we forbid SingleEntry CAFs; they tickle the
324 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
325 -- and I don't understand why. There's only one SE_CAF (well,
326 -- only one that tickled a great gaping bug in an earlier attempt
327 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
328 -- specifically Main.lvl6 in spectral/cryptarithm2.
329 -- So no great loss. KSW 2000-07.
333 %************************************************************************
335 \subsection[coreToStg-atoms{Converting atoms}
337 %************************************************************************
340 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
341 -- Arguments are all value arguments (tyargs already removed), paired with their demand
346 coreArgsToStg env (ad:ads)
347 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
348 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
349 returnUs (bs1 ++ bs2, a' : as')
352 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
353 -- This is where we arrange that a non-trivial argument is let-bound
355 coreArgToStg env (arg,dem)
356 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
358 StgApp v [] -> returnUs (floats, StgVarArg v)
359 StgLit lit -> returnUs (floats, StgLitArg lit)
361 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
362 -- A nullary constructor can be replaced with
363 -- a ``call'' to its wrapper
365 other -> newStgVar arg_ty `thenUs` \ v ->
366 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
368 arg_ty = exprType arg
372 %************************************************************************
374 \subsection[coreToStg-exprs]{Converting core expressions}
376 %************************************************************************
379 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
380 coreExprToStg env expr
381 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
382 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
386 %************************************************************************
388 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
390 %************************************************************************
393 coreExprToStgFloat :: StgEnv -> CoreExpr
394 -> UniqSM ([StgFloatBind], StgExpr)
395 -- Transform an expression to STG. The 'floats' are
396 -- any bindings we had to create for function arguments.
402 coreExprToStgFloat env (Var var)
403 = mkStgApp env var [] (idType var) `thenUs` \ app ->
406 coreExprToStgFloat env (Lit lit)
407 = returnUs ([], StgLit lit)
409 coreExprToStgFloat env (Let bind body)
410 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
411 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
412 returnUs (new_bind:floats, stg_body)
415 Convert core @scc@ expression directly to STG @scc@ expression.
418 coreExprToStgFloat env (Note (SCC cc) expr)
419 = coreExprToStg env expr `thenUs` \ stg_expr ->
420 returnUs ([], StgSCC cc stg_expr)
422 coreExprToStgFloat env (Note other_note expr)
423 = coreExprToStgFloat env expr
427 coreExprToStgFloat env expr@(Type _)
428 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
432 %************************************************************************
434 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
436 %************************************************************************
439 coreExprToStgFloat env expr@(Lam _ _)
441 expr_ty = exprType expr
442 (binders, body) = collectBinders expr
443 id_binders = filter isId binders
445 if null id_binders then -- It was all type binders; tossed
446 coreExprToStgFloat env body
448 -- At least some value binders
449 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
450 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
451 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
454 StgLam ty lam_bndrs lam_body ->
455 -- If the body reduced to a lambda too, join them up
456 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
459 -- Body didn't reduce to a lambda, so return one
460 returnUs ([], mkStgLam expr_ty binders' stg_body')
464 %************************************************************************
466 \subsubsection[coreToStg-applications]{Applications}
468 %************************************************************************
471 coreExprToStgFloat env expr@(App _ _)
473 (fun,rads,ty,ss) = collect_args expr
475 final_ads | null ss = ads
476 | otherwise = zap ads -- Too few args to satisfy strictness info
477 -- so we have to ignore all the strictness info
478 -- e.g. + (error "urk")
479 -- Here, we can't evaluate the arg strictly,
480 -- because this partial application might be seq'd
482 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
484 -- Now deal with the function
485 case (fun, stg_args) of
486 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
487 -- there are no arguments.
488 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
489 returnUs (arg_floats, app)
491 (non_var_fun, []) -> -- No value args, so recurse into the function
492 ASSERT( null arg_floats )
493 coreExprToStgFloat env non_var_fun
495 other -> -- A non-variable applied to things; better let-bind it.
496 newStgVar (exprType fun) `thenUs` \ fn_id ->
497 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
498 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
499 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
503 -- Collect arguments and demands (*in reverse order*)
504 -- collect_args e = (f, args_w_demands, ty, stricts)
505 -- => e = f tys args, (i.e. args are just the value args)
507 -- stricts is the leftover demands of e on its further args
508 -- If stricts runs out, we zap all the demands in args_w_demands
509 -- because partial applications are lazy
511 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
513 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
514 in (the_fun,ads,ty,ss)
515 collect_args (Note InlineCall e) = collect_args e
517 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
518 in (the_fun,ads,applyTy fun_ty tyarg,ss)
519 collect_args (App fun arg)
520 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
522 (ss1, ss_rest) = case ss of
523 (ss1:ss_rest) -> (ss1, ss_rest)
525 (the_fun, ads, fun_ty, ss) = collect_args fun
526 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
527 splitFunTy_maybe fun_ty
530 = (Var v, [], idType v, stricts)
532 stricts = case idStrictness v of
533 StrictnessInfo demands _ -> demands
534 other -> repeat wwLazy
536 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
538 -- "zap" nukes the strictness info for a partial application
539 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
543 %************************************************************************
545 \subsubsection[coreToStg-cases]{Case expressions}
547 %************************************************************************
550 coreExprToStgFloat env (Case scrut bndr alts)
551 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
552 newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
553 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
554 mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
555 returnUs (binds, expr')
557 scrut_ty = idType bndr
558 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
560 alts_to_stg env (alts, deflt)
562 = default_to_stg env deflt `thenUs` \ deflt' ->
563 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
564 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
567 = default_to_stg env deflt `thenUs` \ deflt' ->
568 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
569 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
571 alg_alt_to_stg env (DataAlt con, bs, rhs)
572 = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
573 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
574 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
575 -- NB the filter isId. Some of the binders may be
576 -- existential type variables, which STG doesn't care about
578 prim_alt_to_stg env (LitAlt lit, args, rhs)
579 = ASSERT( null args )
580 coreExprToStg env rhs `thenUs` \ stg_rhs ->
581 returnUs (lit, stg_rhs)
583 default_to_stg env Nothing
584 = returnUs StgNoDefault
586 default_to_stg env (Just rhs)
587 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
588 returnUs (StgBindDefault stg_rhs)
592 %************************************************************************
594 \subsection[coreToStg-misc]{Miscellaneous helping functions}
596 %************************************************************************
598 There's not anything interesting we can ASSERT about \tr{var} if it
599 isn't in the StgEnv. (WDP 94/06)
603 newStgVar :: Type -> UniqSM Id
605 = getUniqueUs `thenUs` \ uniq ->
607 returnUs (mkSysLocal SLIT("stg") uniq ty)
611 newLocalId TopLevel env id
612 -- Don't clone top-level binders. MkIface relies on their
613 -- uniques staying the same, so it can snaffle IdInfo off the
614 -- STG ids to put in interface files.
621 returnUs (env, mkVanillaId name ty)
624 newLocalId NotTopLevel env id
625 = -- Local binder, give it a new unique Id.
626 getUniqueUs `thenUs` \ uniq ->
630 new_id = mkVanillaId (setNameUnique name uniq) ty
631 new_env = extendVarEnv env id new_id
635 returnUs (new_env, new_id)
637 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
638 newLocalIds top_lev env []
640 newLocalIds top_lev env (b:bs)
641 = newLocalId top_lev env b `thenUs` \ (env', b') ->
642 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
643 returnUs (env'', b':bs')
647 %************************************************************************
649 \subsection{Building STG syn}
651 %************************************************************************
654 -- There are two things going on in mkStgAlgAlts
655 -- a) We pull out the type constructor for the case, from the data
656 -- constructor, if there is one. See notes with the StgAlgAlts data type
657 -- b) We force the type constructor to avoid space leaks
659 mkStgAlgAlts ty alts deflt
661 -- Get the tycon from the data con
662 (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
664 -- Otherwise just do your best
665 [] -> case splitTyConApp_maybe (repType ty) of
666 Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
667 other -> StgAlgAlts Nothing alts deflt
669 mkStgPrimAlts ty alts deflt
670 = case splitTyConApp_maybe ty of
671 Just (tc,_) -> StgPrimAlts tc alts deflt
672 Nothing -> pprPanic "mkStgAlgAlts" (ppr ty)
674 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
676 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
677 -- The type is the type of the entire application
678 mkStgApp env fn args ty
679 = case idFlavour fn_alias of
681 -> saturate fn_alias args ty $ \ args' ty' ->
682 returnUs (StgConApp dc args')
684 PrimOpId (CCallOp ccall)
685 -- Sigh...make a guaranteed unique name for a dynamic ccall
686 -- Done here, not earlier, because it's a code-gen thing
687 -> saturate fn_alias args ty $ \ args' ty' ->
688 getUniqueUs `thenUs` \ uniq ->
689 let ccall' = setCCallUnique ccall uniq in
690 returnUs (StgPrimApp (CCallOp ccall') args' ty')
694 -> saturate fn_alias args ty $ \ args' ty' ->
695 returnUs (StgPrimApp op args' ty')
697 other -> returnUs (StgApp fn_alias args)
700 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
704 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
705 -- The type should be the type of (id args)
706 saturate fn args ty thing_inside
707 | excess_arity == 0 -- Saturated, so nothing to do
708 = thing_inside args ty
710 | otherwise -- An unsaturated constructor or primop; eta expand it
711 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
712 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
713 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
714 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
715 returnUs (StgLam ty arg_vars body)
717 fn_arity = idArity fn
718 excess_arity = fn_arity - length args
719 (arg_tys, res_ty) = splitRepFunTys ty
720 extra_arg_tys = take excess_arity arg_tys
721 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
725 -- Stg doesn't have a lambda *expression*
726 deStgLam (StgLam ty bndrs body)
727 -- Try for eta reduction
728 = ASSERT( not (null bndrs) )
730 Just e -> -- Eta succeeded
733 Nothing -> -- Eta failed, so let-bind the lambda
734 newStgVar ty `thenUs` \ fn ->
735 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
737 lam_closure = StgRhsClosure noCCS
741 ReEntrant -- binders is non-empty
746 | n_remaining >= 0 &&
747 and (zipWith ok bndrs last_args) &&
748 notInExpr bndrs remaining_expr
749 = Just remaining_expr
751 remaining_expr = StgApp f remaining_args
752 (remaining_args, last_args) = splitAt n_remaining args
753 n_remaining = length args - length bndrs
755 eta (StgLet bind@(StgNonRec b r) body)
756 | notInRhs bndrs r = case eta body of
757 Just e -> Just (StgLet bind e)
762 ok bndr (StgVarArg arg) = bndr == arg
763 ok bndr other = False
765 deStgLam expr = returnUs expr
768 --------------------------------------------------
769 notInExpr :: [Id] -> StgExpr -> Bool
770 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
771 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
772 notInExpr vs other = False -- Safe
774 notInRhs :: [Id] -> StgRhs -> Bool
775 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
776 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
777 -- Conservative: we could delete the binders from vs, but
778 -- cloning means this will never help
780 notInArgs :: [Id] -> [StgArg] -> Bool
781 notInArgs vs args = all ok args
783 ok (StgVarArg v) = notInId vs v
784 ok (StgLitArg l) = True
786 notInId :: [Id] -> Id -> Bool
787 notInId vs v = not (v `elem` vs)
791 mkStgBinds :: [StgFloatBind]
792 -> StgExpr -- *Can* be a StgLam
793 -> UniqSM StgExpr -- *Can* be a StgLam
795 mkStgBinds [] body = returnUs body
796 mkStgBinds (b:bs) body
797 = deStgLam body `thenUs` \ body' ->
800 go [] body = returnUs body
801 go (b:bs) body = go bs body `thenUs` \ body' ->
804 -- The 'body' arg of mkStgBind can't be a StgLam
805 mkStgBind NoBindF body = returnUs body
806 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
808 mkStgBind (NonRecF bndr rhs dem floats) body
810 -- We shouldn't get let or case of the form v=w
812 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
813 (mk_stg_let bndr rhs dem floats body)
814 other -> mk_stg_let bndr rhs dem floats body
816 mk_stg_let bndr rhs dem floats body
818 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
819 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
820 mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
821 mkStgBinds floats expr'
825 -- Strict let with WHNF rhs
827 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
829 -- Lazy let with WHNF rhs; float until we find a strict binding
831 (floats_out, floats_in) = splitFloats floats
833 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
834 mkStgBinds floats_out $
835 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
837 | otherwise -- Not WHNF
839 -- Strict let with non-WHNF rhs
840 mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
841 mkStgBinds floats expr'
843 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
844 mkStgBinds floats rhs `thenUs` \ new_rhs ->
845 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
848 bndr_rep_ty = repType (idType bndr)
849 is_strict = isStrictDem dem
850 is_whnf = case rhs of
851 StgConApp _ _ -> True
855 -- Split at the first strict binding
856 splitFloats fs@(NonRecF _ _ dem _ : _)
857 | isStrictDem dem = ([], fs)
859 splitFloats (f : fs) = case splitFloats fs of
860 (fs_out, fs_in) -> (f : fs_out, fs_in)
862 splitFloats [] = ([], [])
869 First, two special cases. We mangle cases involving
873 Up to this point, seq# will appear like this:
879 This code comes from an unfolding for 'seq' in Prelude.hs.
880 The 0# branch is purely to bamboozle the strictness analyser.
881 For example, if <stuff> is strict in x, and there was no seqError#
882 branch, the strictness analyser would conclude that the whole expression
883 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
885 Now that the evaluation order is safe, we translate this into
890 This used to be done in the post-simplification phase, but we need
891 unfoldings involving seq# to appear unmangled in the interface file,
892 hence we do this mangling here.
894 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
906 fork# isn't handled like this - it's an explicit IO operation now.
907 The reason is that fork# returns a ThreadId#, which gets in the
908 way of the above scheme. And anyway, IO is the only guaranteed
909 way to enforce ordering --SDM.
913 -- Discard alernatives in case (par# ..) of
914 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
915 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
916 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
918 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
919 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
920 = mkStgCase scrut_expr new_bndr new_alts
922 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
923 | otherwise = mkStgAlgAlts scrut_ty [] deflt
924 scrut_ty = stgArgType scrut
925 new_bndr = setIdType bndr scrut_ty
926 -- NB: SeqOp :: forall a. a -> Int#
927 -- So bndr has type Int#
928 -- But now we are going to scrutinise the SeqOp's argument directly,
929 -- so we must change the type of the case binder to match that
930 -- of the argument expression e.
932 scrut_expr = case scrut of
933 StgVarArg v -> StgApp v []
934 -- Others should not happen because
935 -- seq of a value should have disappeared
936 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
938 mkStgCase scrut bndr alts
939 = deStgLam scrut `thenUs` \ scrut' ->
940 -- It is (just) possible to get a lambda as a srutinee here
941 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
942 -- gives: case ...Bool == Int->Int... of
943 -- True -> case coerce Bool (\x -> + 1 x) of
947 -- The True branch of the outer case will never happen, of course.
949 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)