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