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, coreToStgExpr ) 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, splitTyConApp,
36 splitRepFunTys, mkFunTys,
37 uaUTy, usOnce, usMany, isTyVarTy
39 import UniqSupply -- all of it, really
40 import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
41 import UniqSet ( emptyUniqSet )
42 import ErrUtils ( showPass, dumpIfSet_dyn )
43 import CmdLineOpts ( DynFlags, DynFlag(..) )
49 *************************************************
50 *************** OVERVIEW *********************
51 *************************************************
54 The business of this pass is to convert Core to Stg. On the way it
55 does some important transformations:
57 1. We discard type lambdas and applications. In so doing we discard
58 "trivial" bindings such as
60 where t1, t2 are types
62 2. We get the program into "A-normal form". In particular:
64 f E ==> let x = E in f x
65 OR ==> case E of x -> f x
67 where E is a non-trivial expression.
68 Which transformation is used depends on whether f is strict or not.
69 [Previously the transformation to case used to be done by the
70 simplifier, but it's better done here. It does mean that f needs
71 to have its strictness info correct!.]
73 Similarly, convert any unboxed let's into cases.
74 [I'm experimenting with leaving 'ok-for-speculation' rhss in let-form
75 right up to this point.]
77 3. We clone all local binders. The code generator uses the uniques to
78 name chunks of code for thunks, so it's important that the names used
79 are globally unique, not simply not-in-scope, which is all that
80 the simplifier ensures.
82 4. If we are going to do object-file splitting, we make ALL top-level
83 names into Globals. Why?
85 In certain (prelude only) modules we split up the .hc file into
86 lots of separate little files, which are separately compiled by the C
87 compiler. That gives lots of little .o files. The idea is that if
88 you happen to mention one of them you don't necessarily pull them all
89 in. (Pulling in a piece you don't need can be v bad, because it may
90 mention other pieces you don't need either, and so on.)
92 Sadly, splitting up .hc files means that local names (like s234) are
93 now globally visible, which can lead to clashes between two .hc
94 files. So we make them all Global, so they are printed complete
95 with their module name.
97 We don't want to do this in CoreTidy, because at that stage we use
98 Global to mean "external" and hence "should appear in interface files".
99 This object-file splitting thing is a code generator matter that we
100 don't want to pollute earlier phases.
104 * We don't pin on correct arities any more, because they can be mucked up
105 by the lambda lifter. In particular, the lambda lifter can take a local
106 letrec-bound variable and make it a lambda argument, which shouldn't have
107 an arity. So SetStgVarInfo sets arities now.
109 * We do *not* pin on the correct free/live var info; that's done later.
110 Instead we use bOGUS_LVS and _FVS as a placeholder.
112 [Quite a bit of stuff that used to be here has moved
113 to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
116 %************************************************************************
118 \subsection[coreToStg-programs]{Converting a core program and core bindings}
120 %************************************************************************
122 March 98: We keep a small environment to give all locally bound
123 Names new unique ids, since the code generator assumes that binders
124 are unique across a module. (Simplifier doesn't maintain this
125 invariant any longer.)
127 A binder to be floated out becomes an @StgFloatBind@.
130 type StgEnv = IdEnv Id
132 data StgFloatBind = NoBindF
133 | RecF [(Id, StgRhs)]
136 StgExpr -- *Can* be a StgLam
140 -- The interesting one is the NonRecF
141 -- NonRecF x rhs demand binds
143 -- x = let binds in rhs
144 -- (or possibly case etc if x demand is strict)
145 -- The binds are kept separate so they can be floated futher
149 A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
150 thus case-bound, or if let-bound, at most once (@isOnceDem@) or
154 data RhsDemand = RhsDemand { isStrictDem :: Bool, -- True => used at least once
155 isOnceDem :: Bool -- True => used at most once
158 mkDem :: Demand -> Bool -> RhsDemand
159 mkDem strict once = RhsDemand (isStrict strict) once
161 mkDemTy :: Demand -> Type -> RhsDemand
162 mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
164 isOnceTy :: Type -> Bool
168 opt_UsageSPOn && -- can't expect annotations if -fusagesp is off
173 once | u == usOnce = True
174 | u == usMany = False
175 | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany
177 bdrDem :: Id -> RhsDemand
178 bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
180 safeDem, onceDem :: RhsDemand
181 safeDem = RhsDemand False False -- always safe to use this
182 onceDem = RhsDemand False True -- used at most once
185 No free/live variable information is pinned on in this pass; it's added
187 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
189 When printing out the Stg we need non-bottom values in these
193 bOGUS_LVs :: StgLiveVars
194 bOGUS_LVs = emptyUniqSet
201 topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
202 topCoreBindsToStg dflags core_binds
203 = do showPass dflags "Core2Stg"
204 us <- mkSplitUniqSupply 'c'
205 return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
207 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
209 coreBindsToStg env [] = returnUs []
210 coreBindsToStg env (b:bs)
211 = coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
212 coreBindsToStg new_env bs `thenUs` \ new_bs ->
214 NonRecF bndr rhs dem floats
215 -> ASSERT2( not (isStrictDem dem) &&
216 not (isUnLiftedType (idType bndr)),
217 ppr b ) -- No top-level cases!
219 mkStgBinds floats rhs `thenUs` \ new_rhs ->
220 returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
222 -- Keep all the floats inside...
223 -- Some might be cases etc
224 -- We might want to revisit this decision
226 RecF prs -> returnUs (StgRec prs : new_bs)
227 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
231 %************************************************************************
233 \subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
235 %************************************************************************
238 coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
239 coreToStgExpr dflags core_expr
240 = do showPass dflags "Core2Stg"
241 us <- mkSplitUniqSupply 'c'
242 let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
243 dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
247 %************************************************************************
249 \subsection[coreToStg-binds]{Converting bindings}
251 %************************************************************************
254 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
256 coreBindToStg top_lev env (NonRec binder rhs)
257 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
258 case (floats, stg_rhs) of
259 ([], StgApp var []) | not (isExportedId binder)
260 -> returnUs (NoBindF, extendVarEnv env binder var)
261 -- A trivial binding let x = y in ...
262 -- can arise if postSimplExpr floats a NoRep literal out
263 -- so it seems sensible to deal with it well.
264 -- But we don't want to discard exported things. They can
265 -- occur; e.g. an exported user binding f = g
267 other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
268 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
273 coreBindToStg top_lev env (Rec pairs)
274 = newLocalIds top_lev env binders `thenUs` \ (env', binders') ->
275 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
276 returnUs (RecF (binders' `zip` stg_rhss), env')
278 binders = map fst pairs
279 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
280 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
281 -- NB: stg_expr' might still be a StgLam (and we want that)
282 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
286 %************************************************************************
288 \subsection[coreToStg-rhss]{Converting right hand sides}
290 %************************************************************************
293 exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
294 exprToRhs dem _ (StgLam _ bndrs body)
295 = ASSERT( not (null bndrs) )
300 ReEntrant -- binders is non-empty
305 We reject the following candidates for 'static constructor'dom:
307 - any dcon that takes a lit-lit as an arg.
308 - [Win32 DLLs only]: any dcon that resides in a DLL
309 (or takes as arg something that is.)
311 These constraints are necessary to ensure that the code
312 generated in the end for the static constructors, which
313 live in the data segment, remain valid - i.e., it has to
314 be constant. For obvious reasons, that's hard to guarantee
315 with lit-lits. The second case of a constructor referring
316 to static closures hiding out in some DLL is an artifact
317 of the way Win32 DLLs handle global DLL variables. A (data)
318 symbol exported from a DLL has to be accessed through a
319 level of indirection at the site of use, so whereas
321 extern StgClosure y_closure;
322 extern StgClosure z_closure;
323 x = { ..., &y_closure, &z_closure };
325 is legal when the symbols are in scope at link-time, it is
326 not when y_closure is in a DLL. So, any potential static
327 closures that refers to stuff that's residing in a DLL
328 will be put in an (updateable) thunk instead.
330 An alternative strategy is to support the generation of
331 constructors (ala C++ static class constructors) which will
332 then be run at load time to fix up static closures.
334 exprToRhs dem toplev (StgConApp con args)
335 | isNotTopLevel toplev || not (isDllConApp con args)
336 -- isDllConApp checks for LitLit args too
337 = StgRhsCon noCCS con args
339 exprToRhs dem toplev expr
341 StgRhsClosure noCCS -- No cost centre (ToDo?)
343 noSRT -- figure out later
349 upd = if isOnceDem dem
350 then (if isNotTopLevel toplev
351 then SingleEntry -- HA! Paydirt for "dem"
354 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
358 -- For now we forbid SingleEntry CAFs; they tickle the
359 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
360 -- and I don't understand why. There's only one SE_CAF (well,
361 -- only one that tickled a great gaping bug in an earlier attempt
362 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
363 -- specifically Main.lvl6 in spectral/cryptarithm2.
364 -- So no great loss. KSW 2000-07.
368 %************************************************************************
370 \subsection[coreToStg-atoms{Converting atoms}
372 %************************************************************************
375 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
376 -- Arguments are all value arguments (tyargs already removed), paired with their demand
381 coreArgsToStg env (ad:ads)
382 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
383 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
384 returnUs (bs1 ++ bs2, a' : as')
387 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
388 -- This is where we arrange that a non-trivial argument is let-bound
390 coreArgToStg env (arg,dem)
391 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
393 StgApp v [] -> returnUs (floats, StgVarArg v)
394 StgLit lit -> returnUs (floats, StgLitArg lit)
396 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
397 -- A nullary constructor can be replaced with
398 -- a ``call'' to its wrapper
400 other -> newStgVar arg_ty `thenUs` \ v ->
401 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
403 arg_ty = exprType arg
407 %************************************************************************
409 \subsection[coreToStg-exprs]{Converting core expressions}
411 %************************************************************************
414 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
415 coreExprToStg env expr
416 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
417 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
421 %************************************************************************
423 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
425 %************************************************************************
428 coreExprToStgFloat :: StgEnv -> CoreExpr
429 -> UniqSM ([StgFloatBind], StgExpr)
430 -- Transform an expression to STG. The 'floats' are
431 -- any bindings we had to create for function arguments.
437 coreExprToStgFloat env (Var var)
438 = mkStgApp env var [] (idType var) `thenUs` \ app ->
441 coreExprToStgFloat env (Lit lit)
442 = returnUs ([], StgLit lit)
444 coreExprToStgFloat env (Let bind body)
445 = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
446 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
447 returnUs (new_bind:floats, stg_body)
450 Convert core @scc@ expression directly to STG @scc@ expression.
453 coreExprToStgFloat env (Note (SCC cc) expr)
454 = coreExprToStg env expr `thenUs` \ stg_expr ->
455 returnUs ([], StgSCC cc stg_expr)
457 coreExprToStgFloat env (Note other_note expr)
458 = coreExprToStgFloat env expr
462 coreExprToStgFloat env expr@(Type _)
463 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
467 %************************************************************************
469 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
471 %************************************************************************
474 coreExprToStgFloat env expr@(Lam _ _)
476 expr_ty = exprType expr
477 (binders, body) = collectBinders expr
478 id_binders = filter isId binders
480 if null id_binders then -- It was all type binders; tossed
481 coreExprToStgFloat env body
483 -- At least some value binders
484 newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
485 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
486 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
489 StgLam ty lam_bndrs lam_body ->
490 -- If the body reduced to a lambda too, join them up
491 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
494 -- Body didn't reduce to a lambda, so return one
495 returnUs ([], mkStgLam expr_ty binders' stg_body')
499 %************************************************************************
501 \subsubsection[coreToStg-applications]{Applications}
503 %************************************************************************
506 coreExprToStgFloat env expr@(App _ _)
508 (fun,rads,ty,ss) = collect_args expr
510 final_ads | null ss = ads
511 | otherwise = zap ads -- Too few args to satisfy strictness info
512 -- so we have to ignore all the strictness info
513 -- e.g. + (error "urk")
514 -- Here, we can't evaluate the arg strictly,
515 -- because this partial application might be seq'd
517 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
519 -- Now deal with the function
520 case (fun, stg_args) of
521 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
522 -- there are no arguments.
523 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
524 returnUs (arg_floats, app)
526 (non_var_fun, []) -> -- No value args, so recurse into the function
527 ASSERT( null arg_floats )
528 coreExprToStgFloat env non_var_fun
530 other -> -- A non-variable applied to things; better let-bind it.
531 newStgVar (exprType fun) `thenUs` \ fn_id ->
532 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
533 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
534 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
538 -- Collect arguments and demands (*in reverse order*)
539 -- collect_args e = (f, args_w_demands, ty, stricts)
540 -- => e = f tys args, (i.e. args are just the value args)
542 -- stricts is the leftover demands of e on its further args
543 -- If stricts runs out, we zap all the demands in args_w_demands
544 -- because partial applications are lazy
546 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
548 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
549 in (the_fun,ads,ty,ss)
550 collect_args (Note InlineCall e) = collect_args e
552 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
553 in (the_fun,ads,applyTy fun_ty tyarg,ss)
554 collect_args (App fun arg)
555 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
557 (ss1, ss_rest) = case ss of
558 (ss1:ss_rest) -> (ss1, ss_rest)
560 (the_fun, ads, fun_ty, ss) = collect_args fun
561 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
562 splitFunTy_maybe fun_ty
565 = (Var v, [], idType v, stricts)
567 stricts = case idStrictness v of
568 StrictnessInfo demands _ -> demands
569 other -> repeat wwLazy
571 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
573 -- "zap" nukes the strictness info for a partial application
574 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
578 %************************************************************************
580 \subsubsection[coreToStg-cases]{Case expressions}
582 %************************************************************************
585 coreExprToStgFloat env (Case scrut bndr alts)
586 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
587 newLocalId NotTopLevel env bndr `thenUs` \ (env', bndr') ->
588 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
589 mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
590 returnUs (binds, expr')
592 scrut_ty = idType bndr
593 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
595 alts_to_stg env (alts, deflt)
597 = default_to_stg env deflt `thenUs` \ deflt' ->
598 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
599 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
602 = default_to_stg env deflt `thenUs` \ deflt' ->
603 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
604 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
606 alg_alt_to_stg env (DataAlt con, bs, rhs)
607 = newLocalIds NotTopLevel env (filter isId bs) `thenUs` \ (env', stg_bs) ->
608 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
609 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
610 -- NB the filter isId. Some of the binders may be
611 -- existential type variables, which STG doesn't care about
613 prim_alt_to_stg env (LitAlt lit, args, rhs)
614 = ASSERT( null args )
615 coreExprToStg env rhs `thenUs` \ stg_rhs ->
616 returnUs (lit, stg_rhs)
618 default_to_stg env Nothing
619 = returnUs StgNoDefault
621 default_to_stg env (Just rhs)
622 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
623 returnUs (StgBindDefault stg_rhs)
627 %************************************************************************
629 \subsection[coreToStg-misc]{Miscellaneous helping functions}
631 %************************************************************************
633 There's not anything interesting we can ASSERT about \tr{var} if it
634 isn't in the StgEnv. (WDP 94/06)
638 newStgVar :: Type -> UniqSM Id
640 = getUniqueUs `thenUs` \ uniq ->
642 returnUs (mkSysLocal SLIT("stg") uniq ty)
646 newLocalId TopLevel env id
647 -- Don't clone top-level binders. MkIface relies on their
648 -- uniques staying the same, so it can snaffle IdInfo off the
649 -- STG ids to put in interface files.
656 returnUs (env, mkVanillaId name ty)
659 newLocalId NotTopLevel env id
660 = -- Local binder, give it a new unique Id.
661 getUniqueUs `thenUs` \ uniq ->
665 new_id = mkVanillaId (setNameUnique name uniq) ty
666 new_env = extendVarEnv env id new_id
670 returnUs (new_env, new_id)
672 newLocalIds :: TopLevelFlag -> StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
673 newLocalIds top_lev env []
676 newLocalIds top_lev env (b:bs)
677 = newLocalId top_lev env b `thenUs` \ (env', b') ->
678 newLocalIds top_lev env' bs `thenUs` \ (env'', bs') ->
679 returnUs (env'', b':bs')
683 %************************************************************************
685 \subsection{Building STG syn}
687 %************************************************************************
690 -- There are two things going on in mkStgAlgAlts
691 -- a) We pull out the type constructor for the case, from the data
692 -- constructor, if there is one. See notes with the StgAlgAlts data type
693 -- b) We force the type constructor to avoid space leaks
695 mkStgAlgAlts ty alts deflt
697 -- Get the tycon from the data con
698 (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
700 -- Otherwise just do your best
701 [] -> case splitTyConApp_maybe (repType ty) of
702 Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
703 other -> StgAlgAlts Nothing alts deflt
705 mkStgPrimAlts ty alts deflt
706 = case splitTyConApp ty of
707 (tc,_) -> StgPrimAlts tc alts deflt
709 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
711 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
712 -- The type is the type of the entire application
713 mkStgApp env fn args ty
714 = case idFlavour fn_alias of
716 -> saturate fn_alias args ty $ \ args' ty' ->
717 returnUs (StgConApp dc args')
719 PrimOpId (CCallOp ccall)
720 -- Sigh...make a guaranteed unique name for a dynamic ccall
721 -- Done here, not earlier, because it's a code-gen thing
722 -> saturate fn_alias args ty $ \ args' ty' ->
723 getUniqueUs `thenUs` \ uniq ->
724 let ccall' = setCCallUnique ccall uniq in
725 returnUs (StgPrimApp (CCallOp ccall') args' ty')
729 -> saturate fn_alias args ty $ \ args' ty' ->
730 returnUs (StgPrimApp op args' ty')
732 other -> returnUs (StgApp fn_alias args)
735 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
739 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
740 -- The type should be the type of (id args)
741 saturate fn args ty thing_inside
742 | excess_arity == 0 -- Saturated, so nothing to do
743 = thing_inside args ty
745 | otherwise -- An unsaturated constructor or primop; eta expand it
746 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
747 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
748 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
749 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
750 returnUs (StgLam ty arg_vars body)
752 fn_arity = idArity fn
753 excess_arity = fn_arity - length args
754 (arg_tys, res_ty) = splitRepFunTys ty
755 extra_arg_tys = take excess_arity arg_tys
756 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
760 -- Stg doesn't have a lambda *expression*
761 deStgLam (StgLam ty bndrs body)
762 -- Try for eta reduction
763 = ASSERT( not (null bndrs) )
765 Just e -> -- Eta succeeded
768 Nothing -> -- Eta failed, so let-bind the lambda
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
781 | n_remaining >= 0 &&
782 and (zipWith ok bndrs last_args) &&
783 notInExpr bndrs remaining_expr
784 = Just remaining_expr
786 remaining_expr = StgApp f remaining_args
787 (remaining_args, last_args) = splitAt n_remaining args
788 n_remaining = length args - length bndrs
790 eta (StgLet bind@(StgNonRec b r) body)
791 | notInRhs bndrs r = case eta body of
792 Just e -> Just (StgLet bind e)
797 ok bndr (StgVarArg arg) = bndr == arg
798 ok bndr other = False
800 deStgLam expr = returnUs expr
803 --------------------------------------------------
804 notInExpr :: [Id] -> StgExpr -> Bool
805 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
806 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
807 notInExpr vs other = False -- Safe
809 notInRhs :: [Id] -> StgRhs -> Bool
810 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
811 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
812 -- Conservative: we could delete the binders from vs, but
813 -- cloning means this will never help
815 notInArgs :: [Id] -> [StgArg] -> Bool
816 notInArgs vs args = all ok args
818 ok (StgVarArg v) = notInId vs v
819 ok (StgLitArg l) = True
821 notInId :: [Id] -> Id -> Bool
822 notInId vs v = not (v `elem` vs)
826 mkStgBinds :: [StgFloatBind]
827 -> StgExpr -- *Can* be a StgLam
828 -> UniqSM StgExpr -- *Can* be a StgLam
830 mkStgBinds [] body = returnUs body
831 mkStgBinds (b:bs) body
832 = deStgLam body `thenUs` \ body' ->
835 go [] body = returnUs body
836 go (b:bs) body = go bs body `thenUs` \ body' ->
839 -- The 'body' arg of mkStgBind can't be a StgLam
840 mkStgBind NoBindF body = returnUs body
841 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
843 mkStgBind (NonRecF bndr rhs dem floats) body
845 -- We shouldn't get let or case of the form v=w
847 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
848 (mk_stg_let bndr rhs dem floats body)
849 other -> mk_stg_let bndr rhs dem floats body
851 mk_stg_let bndr rhs dem floats body
853 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
854 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
855 mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
856 mkStgBinds floats expr'
860 -- Strict let with WHNF rhs
862 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
864 -- Lazy let with WHNF rhs; float until we find a strict binding
866 (floats_out, floats_in) = splitFloats floats
868 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
869 mkStgBinds floats_out $
870 StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
872 | otherwise -- Not WHNF
874 -- Strict let with non-WHNF rhs
875 mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
876 mkStgBinds floats expr'
878 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
879 mkStgBinds floats rhs `thenUs` \ new_rhs ->
880 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
883 bndr_rep_ty = repType (idType bndr)
884 is_strict = isStrictDem dem
885 is_whnf = case rhs of
886 StgConApp _ _ -> True
890 -- Split at the first strict binding
891 splitFloats fs@(NonRecF _ _ dem _ : _)
892 | isStrictDem dem = ([], fs)
894 splitFloats (f : fs) = case splitFloats fs of
895 (fs_out, fs_in) -> (f : fs_out, fs_in)
897 splitFloats [] = ([], [])
904 First, two special cases. We mangle cases involving
908 Up to this point, seq# will appear like this:
914 This code comes from an unfolding for 'seq' in Prelude.hs.
915 The 0# branch is purely to bamboozle the strictness analyser.
916 For example, if <stuff> is strict in x, and there was no seqError#
917 branch, the strictness analyser would conclude that the whole expression
918 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
920 Now that the evaluation order is safe, we translate this into
925 This used to be done in the post-simplification phase, but we need
926 unfoldings involving seq# to appear unmangled in the interface file,
927 hence we do this mangling here.
929 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
941 fork# isn't handled like this - it's an explicit IO operation now.
942 The reason is that fork# returns a ThreadId#, which gets in the
943 way of the above scheme. And anyway, IO is the only guaranteed
944 way to enforce ordering --SDM.
948 -- Discard alernatives in case (par# ..) of
949 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
950 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
951 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
953 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
954 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
955 = mkStgCase scrut_expr new_bndr new_alts
957 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
958 | otherwise = mkStgAlgAlts scrut_ty [] deflt
959 scrut_ty = stgArgType scrut
960 new_bndr = setIdType bndr scrut_ty
961 -- NB: SeqOp :: forall a. a -> Int#
962 -- So bndr has type Int#
963 -- But now we are going to scrutinise the SeqOp's argument directly,
964 -- so we must change the type of the case binder to match that
965 -- of the argument expression e.
967 scrut_expr = case scrut of
968 StgVarArg v -> StgApp v []
969 -- Others should not happen because
970 -- seq of a value should have disappeared
971 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
973 mkStgCase scrut bndr alts
974 = deStgLam scrut `thenUs` \ scrut' ->
975 -- It is (just) possible to get a lambda as a srutinee here
976 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
977 -- gives: case ...Bool == Int->Int... of
978 -- True -> case coerce Bool (\x -> + 1 x) of
982 -- The True branch of the outer case will never happen, of course.
984 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)