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,
24 mkVanillaId, idName, idDemandInfo, idArity, setIdType,
27 import Module ( Module )
28 import IdInfo ( StrictnessInfo(..), IdFlavour(..) )
29 import DataCon ( dataConWrapId, dataConTyCon )
30 import TyCon ( isAlgTyCon )
31 import Demand ( Demand, isStrict, wwLazy )
32 import Name ( setNameUnique, globaliseName, isLocalName, isGlobalName )
34 import PrimOp ( PrimOp(..), setCCallUnique )
35 import Type ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
36 applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
37 splitRepFunTys, mkFunTys,
38 uaUTy, usOnce, usMany, isTyVarTy
40 import UniqSupply -- all of it, really
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 -> Module -> [CoreBind] -> IO [StgBinding]
202 topCoreBindsToStg dflags mod core_binds
203 = do showPass dflags "Core2Stg"
204 us <- mkSplitUniqSupply 'c'
205 return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))
209 coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
211 coreBindsToStg env [] = returnUs []
212 coreBindsToStg env (b:bs)
213 = coreBindToStg top_flag env b `thenUs` \ (bind_spec, new_env) ->
214 coreBindsToStg new_env bs `thenUs` \ new_bs ->
216 NonRecF bndr rhs dem floats
217 -> ASSERT2( not (isStrictDem dem) &&
218 not (isUnLiftedType (idType bndr)),
219 ppr b ) -- No top-level cases!
221 mkStgBinds floats rhs `thenUs` \ new_rhs ->
222 returnUs (StgNonRec bndr (exprToRhs dem top_flag new_rhs)
224 -- Keep all the floats inside...
225 -- Some might be cases etc
226 -- We might want to revisit this decision
228 RecF prs -> returnUs (StgRec prs : new_bs)
229 NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
233 %************************************************************************
235 \subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
237 %************************************************************************
240 coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
241 coreToStgExpr dflags core_expr
242 = do showPass dflags "Core2Stg"
243 us <- mkSplitUniqSupply 'c'
244 let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
245 dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
249 %************************************************************************
251 \subsection[coreToStg-binds]{Converting bindings}
253 %************************************************************************
256 coreBindToStg :: TopLvl -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
258 coreBindToStg top_lev env (NonRec binder rhs)
259 = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_rhs) ->
260 case (floats, stg_rhs) of
262 | not (isGlobalName (idName binder))
263 -> returnUs (NoBindF, extendVarEnv env binder var)
266 -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
267 returnUs (NonRecF new_binder stg_rhs dem floats, extendVarEnv new_env binder var)
268 -- A trivial binding let x = y in ...
269 -- can arise if postSimplExpr floats a NoRep literal out
270 -- so it seems sensible to deal with it well.
271 -- But we don't want to discard exported things. They can
272 -- occur; e.g. an exported user binding f = g
274 other -> newBinder top_lev env binder `thenUs` \ (new_env, new_binder) ->
275 returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
280 coreBindToStg top_lev env (Rec pairs)
281 = newBinders top_lev env binders `thenUs` \ (env', binders') ->
282 mapUs (do_rhs env') pairs `thenUs` \ stg_rhss ->
283 returnUs (RecF (binders' `zip` stg_rhss), env')
285 binders = map fst pairs
286 do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs `thenUs` \ (floats, stg_expr) ->
287 mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
288 -- NB: stg_expr' might still be a StgLam (and we want that)
289 returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')
293 %************************************************************************
295 \subsection[coreToStg-rhss]{Converting right hand sides}
297 %************************************************************************
300 exprToRhs :: RhsDemand -> TopLvl -> StgExpr -> StgRhs
301 exprToRhs dem _ (StgLam _ bndrs body)
302 = ASSERT( not (null bndrs) )
307 ReEntrant -- binders is non-empty
312 We reject the following candidates for 'static constructor'dom:
314 - any dcon that takes a lit-lit as an arg.
315 - [Win32 DLLs only]: any dcon that resides in a DLL
316 (or takes as arg something that is.)
318 These constraints are necessary to ensure that the code
319 generated in the end for the static constructors, which
320 live in the data segment, remain valid - i.e., it has to
321 be constant. For obvious reasons, that's hard to guarantee
322 with lit-lits. The second case of a constructor referring
323 to static closures hiding out in some DLL is an artifact
324 of the way Win32 DLLs handle global DLL variables. A (data)
325 symbol exported from a DLL has to be accessed through a
326 level of indirection at the site of use, so whereas
328 extern StgClosure y_closure;
329 extern StgClosure z_closure;
330 x = { ..., &y_closure, &z_closure };
332 is legal when the symbols are in scope at link-time, it is
333 not when y_closure is in a DLL. So, any potential static
334 closures that refers to stuff that's residing in a DLL
335 will be put in an (updateable) thunk instead.
337 An alternative strategy is to support the generation of
338 constructors (ala C++ static class constructors) which will
339 then be run at load time to fix up static closures.
341 exprToRhs dem toplev (StgConApp con args)
342 | isNotTop toplev || not (isDllConApp con args)
343 -- isDllConApp checks for LitLit args too
344 = StgRhsCon noCCS con args
346 exprToRhs dem toplev expr
348 StgRhsClosure noCCS -- No cost centre (ToDo?)
350 noSRT -- figure out later
356 upd = if isOnceDem dem
357 then (if isNotTop toplev
358 then SingleEntry -- HA! Paydirt for "dem"
361 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
365 -- For now we forbid SingleEntry CAFs; they tickle the
366 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
367 -- and I don't understand why. There's only one SE_CAF (well,
368 -- only one that tickled a great gaping bug in an earlier attempt
369 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
370 -- specifically Main.lvl6 in spectral/cryptarithm2.
371 -- So no great loss. KSW 2000-07.
375 %************************************************************************
377 \subsection[coreToStg-atoms{Converting atoms}
379 %************************************************************************
382 coreArgsToStg :: StgEnv -> [(CoreArg,RhsDemand)] -> UniqSM ([StgFloatBind], [StgArg])
383 -- Arguments are all value arguments (tyargs already removed), paired with their demand
388 coreArgsToStg env (ad:ads)
389 = coreArgToStg env ad `thenUs` \ (bs1, a') ->
390 coreArgsToStg env ads `thenUs` \ (bs2, as') ->
391 returnUs (bs1 ++ bs2, a' : as')
394 coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
395 -- This is where we arrange that a non-trivial argument is let-bound
397 coreArgToStg env (arg,dem)
398 = coreExprToStgFloat env arg `thenUs` \ (floats, arg') ->
400 StgApp v [] -> returnUs (floats, StgVarArg v)
401 StgLit lit -> returnUs (floats, StgLitArg lit)
403 StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
404 -- A nullary constructor can be replaced with
405 -- a ``call'' to its wrapper
407 other -> newStgVar arg_ty `thenUs` \ v ->
408 returnUs ([NonRecF v arg' dem floats], StgVarArg v)
410 arg_ty = exprType arg
414 %************************************************************************
416 \subsection[coreToStg-exprs]{Converting core expressions}
418 %************************************************************************
421 coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
422 coreExprToStg env expr
423 = coreExprToStgFloat env expr `thenUs` \ (binds,stg_expr) ->
424 mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
428 %************************************************************************
430 \subsubsection[coreToStg-let(rec)]{Let and letrec expressions}
432 %************************************************************************
435 coreExprToStgFloat :: StgEnv -> CoreExpr
436 -> UniqSM ([StgFloatBind], StgExpr)
437 -- Transform an expression to STG. The 'floats' are
438 -- any bindings we had to create for function arguments.
444 coreExprToStgFloat env (Var var)
445 = mkStgApp env var [] (idType var) `thenUs` \ app ->
448 coreExprToStgFloat env (Lit lit)
449 = returnUs ([], StgLit lit)
451 coreExprToStgFloat env (Let bind body)
452 = coreBindToStg NotTop env bind `thenUs` \ (new_bind, new_env) ->
453 coreExprToStgFloat new_env body `thenUs` \ (floats, stg_body) ->
454 returnUs (new_bind:floats, stg_body)
457 Convert core @scc@ expression directly to STG @scc@ expression.
460 coreExprToStgFloat env (Note (SCC cc) expr)
461 = coreExprToStg env expr `thenUs` \ stg_expr ->
462 returnUs ([], StgSCC cc stg_expr)
464 coreExprToStgFloat env (Note other_note expr)
465 = coreExprToStgFloat env expr
469 coreExprToStgFloat env expr@(Type _)
470 = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
474 %************************************************************************
476 \subsubsection[coreToStg-lambdas]{Lambda abstractions}
478 %************************************************************************
481 coreExprToStgFloat env expr@(Lam _ _)
483 expr_ty = exprType expr
484 (binders, body) = collectBinders expr
485 id_binders = filter isId binders
487 if null id_binders then -- It was all type binders; tossed
488 coreExprToStgFloat env body
490 -- At least some value binders
491 newLocalBinders env id_binders `thenUs` \ (env', binders') ->
492 coreExprToStgFloat env' body `thenUs` \ (floats, stg_body) ->
493 mkStgBinds floats stg_body `thenUs` \ stg_body' ->
496 StgLam ty lam_bndrs lam_body ->
497 -- If the body reduced to a lambda too, join them up
498 returnUs ([], mkStgLam expr_ty (binders' ++ lam_bndrs) lam_body)
501 -- Body didn't reduce to a lambda, so return one
502 returnUs ([], mkStgLam expr_ty binders' stg_body')
506 %************************************************************************
508 \subsubsection[coreToStg-applications]{Applications}
510 %************************************************************************
513 coreExprToStgFloat env expr@(App _ _)
515 (fun,rads,ty,ss) = collect_args expr
517 final_ads | null ss = ads
518 | otherwise = zap ads -- Too few args to satisfy strictness info
519 -- so we have to ignore all the strictness info
520 -- e.g. + (error "urk")
521 -- Here, we can't evaluate the arg strictly,
522 -- because this partial application might be seq'd
524 coreArgsToStg env final_ads `thenUs` \ (arg_floats, stg_args) ->
526 -- Now deal with the function
527 case (fun, stg_args) of
528 (Var fn_id, _) -> -- A function Id, so do an StgApp; it's ok if
529 -- there are no arguments.
530 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
531 returnUs (arg_floats, app)
533 (non_var_fun, []) -> -- No value args, so recurse into the function
534 ASSERT( null arg_floats )
535 coreExprToStgFloat env non_var_fun
537 other -> -- A non-variable applied to things; better let-bind it.
538 newStgVar (exprType fun) `thenUs` \ fn_id ->
539 coreExprToStgFloat env fun `thenUs` \ (fun_floats, stg_fun) ->
540 mkStgApp env fn_id stg_args ty `thenUs` \ app ->
541 returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
545 -- Collect arguments and demands (*in reverse order*)
546 -- collect_args e = (f, args_w_demands, ty, stricts)
547 -- => e = f tys args, (i.e. args are just the value args)
549 -- stricts is the leftover demands of e on its further args
550 -- If stricts runs out, we zap all the demands in args_w_demands
551 -- because partial applications are lazy
553 collect_args :: CoreExpr -> (CoreExpr, [(CoreExpr,RhsDemand)], Type, [Demand])
555 collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
556 in (the_fun,ads,ty,ss)
557 collect_args (Note InlineCall e) = collect_args e
559 collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
560 in (the_fun,ads,applyTy fun_ty tyarg,ss)
561 collect_args (App fun arg)
562 = (the_fun, (arg, mkDemTy ss1 arg_ty) : ads, res_ty, ss_rest)
564 (ss1, ss_rest) = case ss of
565 (ss1:ss_rest) -> (ss1, ss_rest)
567 (the_fun, ads, fun_ty, ss) = collect_args fun
568 (arg_ty, res_ty) = expectJust "coreExprToStgFloat:collect_args" $
569 splitFunTy_maybe fun_ty
572 = (Var v, [], idType v, stricts)
574 stricts = case idStrictness v of
575 StrictnessInfo demands _ -> demands
576 other -> repeat wwLazy
578 collect_args fun = (fun, [], exprType fun, repeat wwLazy)
580 -- "zap" nukes the strictness info for a partial application
581 zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
585 %************************************************************************
587 \subsubsection[coreToStg-cases]{Case expressions}
589 %************************************************************************
592 coreExprToStgFloat env (Case scrut bndr alts)
593 = coreExprToStgFloat env scrut `thenUs` \ (binds, scrut') ->
594 newLocalBinder env bndr `thenUs` \ (env', bndr') ->
595 alts_to_stg env' (findDefault alts) `thenUs` \ alts' ->
596 mkStgCase scrut' bndr' alts' `thenUs` \ expr' ->
597 returnUs (binds, expr')
599 scrut_ty = idType bndr
600 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
602 alts_to_stg env (alts, deflt)
604 = default_to_stg env deflt `thenUs` \ deflt' ->
605 mapUs (prim_alt_to_stg env) alts `thenUs` \ alts' ->
606 returnUs (mkStgPrimAlts scrut_ty alts' deflt')
609 = default_to_stg env deflt `thenUs` \ deflt' ->
610 mapUs (alg_alt_to_stg env) alts `thenUs` \ alts' ->
611 returnUs (mkStgAlgAlts scrut_ty alts' deflt')
613 alg_alt_to_stg env (DataAlt con, bs, rhs)
614 = newLocalBinders env (filter isId bs) `thenUs` \ (env', stg_bs) ->
615 coreExprToStg env' rhs `thenUs` \ stg_rhs ->
616 returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
617 -- NB the filter isId. Some of the binders may be
618 -- existential type variables, which STG doesn't care about
620 prim_alt_to_stg env (LitAlt lit, args, rhs)
621 = ASSERT( null args )
622 coreExprToStg env rhs `thenUs` \ stg_rhs ->
623 returnUs (lit, stg_rhs)
625 default_to_stg env Nothing
626 = returnUs StgNoDefault
628 default_to_stg env (Just rhs)
629 = coreExprToStg env rhs `thenUs` \ stg_rhs ->
630 returnUs (StgBindDefault stg_rhs)
634 %************************************************************************
636 \subsection[coreToStg-misc]{Miscellaneous helping functions}
638 %************************************************************************
640 There's not anything interesting we can ASSERT about \tr{var} if it
641 isn't in the StgEnv. (WDP 94/06)
645 newStgVar :: Type -> UniqSM Id
647 = getUniqueUs `thenUs` \ uniq ->
649 returnUs (mkSysLocal SLIT("stg") uniq ty)
653 ----------------------------
654 data TopLvl = Top Module | NotTop
656 isNotTop NotTop = True
657 isNotTop (Top _) = False
659 ----------------------------
660 newBinder :: TopLvl -> StgEnv -> Id -> UniqSM (StgEnv, Id)
661 newBinder (Top mod) env id = returnUs (env, newTopBinder mod id)
662 newBinder NotTop env id = newLocalBinder env id
664 newBinders (Top mod) env ids = returnUs (env, map (newTopBinder mod) ids)
665 newBinders NotTop env ids = newLocalBinders env ids
668 ----------------------------
670 -- Don't clone top-level binders. MkIface relies on their
671 -- uniques staying the same, so it can snaffle IdInfo off the
672 -- STG ids to put in interface files.
678 name' | isLocalName name = globaliseName name mod
682 ----------------------------
683 newLocalBinder :: StgEnv -> Id -> UniqSM (StgEnv, Id)
684 newLocalBinder env id
685 = -- Local binder, give it a new unique Id.
686 getUniqueUs `thenUs` \ uniq ->
690 new_id = mkVanillaId (setNameUnique name uniq) ty
691 new_env = extendVarEnv env id new_id
695 returnUs (new_env, new_id)
697 ----------------------------
698 newLocalBinders :: StgEnv -> [Id] -> UniqSM (StgEnv, [Id])
699 newLocalBinders env []
702 newLocalBinders env (b:bs)
703 = newLocalBinder env b `thenUs` \ (env', b') ->
704 newLocalBinders env' bs `thenUs` \ (env'', bs') ->
705 returnUs (env'', b':bs')
709 %************************************************************************
711 \subsection{Building STG syn}
713 %************************************************************************
716 -- There are two things going on in mkStgAlgAlts
717 -- a) We pull out the type constructor for the case, from the data
718 -- constructor, if there is one. See notes with the StgAlgAlts data type
719 -- b) We force the type constructor to avoid space leaks
721 mkStgAlgAlts ty alts deflt
723 -- Get the tycon from the data con
724 (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
726 -- Otherwise just do your best
727 [] -> case splitTyConApp_maybe (repType ty) of
728 Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
729 other -> StgAlgAlts Nothing alts deflt
731 mkStgPrimAlts ty alts deflt
732 = case splitTyConApp ty of
733 (tc,_) -> StgPrimAlts tc alts deflt
735 mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
737 mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
738 -- The type is the type of the entire application
739 mkStgApp env fn args ty
740 = case idFlavour fn_alias of
742 -> saturate fn_alias args ty $ \ args' ty' ->
743 returnUs (StgConApp dc args')
745 PrimOpId (CCallOp ccall)
746 -- Sigh...make a guaranteed unique name for a dynamic ccall
747 -- Done here, not earlier, because it's a code-gen thing
748 -> saturate fn_alias args ty $ \ args' ty' ->
749 getUniqueUs `thenUs` \ uniq ->
750 let ccall' = setCCallUnique ccall uniq in
751 returnUs (StgPrimApp (CCallOp ccall') args' ty')
755 -> saturate fn_alias args ty $ \ args' ty' ->
756 returnUs (StgPrimApp op args' ty')
758 other -> returnUs (StgApp fn_alias args)
761 fn_alias = case (lookupVarEnv env fn) of -- In case it's been cloned
765 saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
766 -- The type should be the type of (id args)
767 saturate fn args ty thing_inside
768 | excess_arity == 0 -- Saturated, so nothing to do
769 = thing_inside args ty
771 | otherwise -- An unsaturated constructor or primop; eta expand it
772 = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys,
773 ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
774 mapUs newStgVar extra_arg_tys `thenUs` \ arg_vars ->
775 thing_inside (args ++ map StgVarArg arg_vars) final_res_ty `thenUs` \ body ->
776 returnUs (StgLam ty arg_vars body)
778 fn_arity = idArity fn
779 excess_arity = fn_arity - length args
780 (arg_tys, res_ty) = splitRepFunTys ty
781 extra_arg_tys = take excess_arity arg_tys
782 final_res_ty = mkFunTys (drop excess_arity arg_tys) res_ty
786 -- Stg doesn't have a lambda *expression*
787 deStgLam (StgLam ty bndrs body)
788 -- Try for eta reduction
789 = ASSERT( not (null bndrs) )
791 Just e -> -- Eta succeeded
794 Nothing -> -- Eta failed, so let-bind the lambda
795 newStgVar ty `thenUs` \ fn ->
796 returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
798 lam_closure = StgRhsClosure noCCS
802 ReEntrant -- binders is non-empty
807 | n_remaining >= 0 &&
808 and (zipWith ok bndrs last_args) &&
809 notInExpr bndrs remaining_expr
810 = Just remaining_expr
812 remaining_expr = StgApp f remaining_args
813 (remaining_args, last_args) = splitAt n_remaining args
814 n_remaining = length args - length bndrs
816 eta (StgLet bind@(StgNonRec b r) body)
817 | notInRhs bndrs r = case eta body of
818 Just e -> Just (StgLet bind e)
823 ok bndr (StgVarArg arg) = bndr == arg
824 ok bndr other = False
826 deStgLam expr = returnUs expr
829 --------------------------------------------------
830 notInExpr :: [Id] -> StgExpr -> Bool
831 notInExpr vs (StgApp f args) = notInId vs f && notInArgs vs args
832 notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
833 notInExpr vs other = False -- Safe
835 notInRhs :: [Id] -> StgRhs -> Bool
836 notInRhs vs (StgRhsCon _ _ args) = notInArgs vs args
837 notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
838 -- Conservative: we could delete the binders from vs, but
839 -- cloning means this will never help
841 notInArgs :: [Id] -> [StgArg] -> Bool
842 notInArgs vs args = all ok args
844 ok (StgVarArg v) = notInId vs v
845 ok (StgLitArg l) = True
847 notInId :: [Id] -> Id -> Bool
848 notInId vs v = not (v `elem` vs)
852 mkStgBinds :: [StgFloatBind]
853 -> StgExpr -- *Can* be a StgLam
854 -> UniqSM StgExpr -- *Can* be a StgLam
856 mkStgBinds [] body = returnUs body
857 mkStgBinds (b:bs) body
858 = deStgLam body `thenUs` \ body' ->
861 go [] body = returnUs body
862 go (b:bs) body = go bs body `thenUs` \ body' ->
865 -- The 'body' arg of mkStgBind can't be a StgLam
866 mkStgBind NoBindF body = returnUs body
867 mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
869 mkStgBind (NonRecF bndr rhs dem floats) body
871 -- We shouldn't get let or case of the form v=w
873 StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
874 (mk_stg_let bndr rhs dem floats body)
875 other -> mk_stg_let bndr rhs dem floats body
877 mk_stg_let bndr rhs dem floats body
879 | isUnLiftedType bndr_rep_ty -- Use a case/PrimAlts
880 = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
881 mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
882 mkStgBinds floats expr'
886 -- Strict let with WHNF rhs
888 StgLet (StgNonRec bndr (exprToRhs dem NotTop rhs)) body
890 -- Lazy let with WHNF rhs; float until we find a strict binding
892 (floats_out, floats_in) = splitFloats floats
894 mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
895 mkStgBinds floats_out $
896 StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body
898 | otherwise -- Not WHNF
900 -- Strict let with non-WHNF rhs
901 mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body)) `thenUs` \ expr' ->
902 mkStgBinds floats expr'
904 -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
905 mkStgBinds floats rhs `thenUs` \ new_rhs ->
906 returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTop new_rhs)) body)
909 bndr_rep_ty = repType (idType bndr)
910 is_strict = isStrictDem dem
911 is_whnf = case rhs of
912 StgConApp _ _ -> True
916 -- Split at the first strict binding
917 splitFloats fs@(NonRecF _ _ dem _ : _)
918 | isStrictDem dem = ([], fs)
920 splitFloats (f : fs) = case splitFloats fs of
921 (fs_out, fs_in) -> (f : fs_out, fs_in)
923 splitFloats [] = ([], [])
930 First, two special cases. We mangle cases involving
934 Up to this point, seq# will appear like this:
940 This code comes from an unfolding for 'seq' in Prelude.hs.
941 The 0# branch is purely to bamboozle the strictness analyser.
942 For example, if <stuff> is strict in x, and there was no seqError#
943 branch, the strictness analyser would conclude that the whole expression
944 was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
946 Now that the evaluation order is safe, we translate this into
951 This used to be done in the post-simplification phase, but we need
952 unfoldings involving seq# to appear unmangled in the interface file,
953 hence we do this mangling here.
955 Similarly, par# has an unfolding in PrelConc.lhs that makes it show
967 fork# isn't handled like this - it's an explicit IO operation now.
968 The reason is that fork# returns a ThreadId#, which gets in the
969 way of the above scheme. And anyway, IO is the only guaranteed
970 way to enforce ordering --SDM.
974 -- Discard alernatives in case (par# ..) of
975 mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
976 (StgPrimAlts tycon _ deflt@(StgBindDefault _))
977 = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
979 mkStgCase (StgPrimApp SeqOp [scrut] _) bndr
980 (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
981 = mkStgCase scrut_expr new_bndr new_alts
983 new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
984 | otherwise = mkStgAlgAlts scrut_ty [] deflt
985 scrut_ty = stgArgType scrut
986 new_bndr = setIdType bndr scrut_ty
987 -- NB: SeqOp :: forall a. a -> Int#
988 -- So bndr has type Int#
989 -- But now we are going to scrutinise the SeqOp's argument directly,
990 -- so we must change the type of the case binder to match that
991 -- of the argument expression e.
993 scrut_expr = case scrut of
994 StgVarArg v -> StgApp v []
995 -- Others should not happen because
996 -- seq of a value should have disappeared
997 StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
999 mkStgCase scrut bndr alts
1000 = deStgLam scrut `thenUs` \ scrut' ->
1001 -- It is (just) possible to get a lambda as a srutinee here
1002 -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
1003 -- gives: case ...Bool == Int->Int... of
1004 -- True -> case coerce Bool (\x -> + 1 x) of
1008 -- The True branch of the outer case will never happen, of course.
1010 returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)