2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[CoreToStg]{Converts Core to STG Syntax}
6 And, as we have the info in hand, we may convert some lets to
10 module CoreToStg ( coreToStg, coreExprToStg ) where
12 #include "HsVersions.h"
19 import TyCon ( isAlgTyCon )
22 import Var ( Var, globalIdDetails, varType )
24 import MkId ( unsafeCoerceId )
28 import CostCentre ( noCCS )
31 import Maybes ( maybeToBool )
32 import Name ( getOccName, isExternalName, isDllName )
33 import OccName ( occNameUserString )
34 import BasicTypes ( Arity )
35 import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
36 import FastTypes hiding ( fastOr )
37 import Util ( listLengthCmp, mapAndUnzip )
43 %************************************************************************
45 \subsection[live-vs-free-doc]{Documentation}
47 %************************************************************************
49 (There is other relevant documentation in codeGen/CgLetNoEscape.)
51 The actual Stg datatype is decorated with {\em live variable}
52 information, as well as {\em free variable} information. The two are
53 {\em not} the same. Liveness is an operational property rather than a
54 semantic one. A variable is live at a particular execution point if
55 it can be referred to {\em directly} again. In particular, a dead
56 variable's stack slot (if it has one):
59 should be stubbed to avoid space leaks, and
61 may be reused for something else.
64 There ought to be a better way to say this. Here are some examples:
71 Just after the `in', v is live, but q is dead. If the whole of that
72 let expression was enclosed in a case expression, thus:
74 case (let v = [q] \[x] -> e in ...v...) of
77 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
78 we'll return later to the @alts@ and need it.
80 Let-no-escapes make this a bit more interesting:
82 let-no-escape v = [q] \ [x] -> e
86 Here, @q@ is still live at the `in', because @v@ is represented not by
87 a closure but by the current stack state. In other words, if @v@ is
88 live then so is @q@. Furthermore, if @e@ mentions an enclosing
89 let-no-escaped variable, then {\em its} free variables are also live
92 %************************************************************************
94 \subsection[caf-info]{Collecting live CAF info}
96 %************************************************************************
98 In this pass we also collect information on which CAFs are live for
99 constructing SRTs (see SRT.lhs).
101 A top-level Id has CafInfo, which is
103 - MayHaveCafRefs, if it may refer indirectly to
105 - NoCafRefs if it definitely doesn't
107 we collect the CafInfo first by analysing the original Core expression, and
108 also place this information in the environment.
110 During CoreToStg, we then pin onto each binding and case expression, a
111 list of Ids which represents the "live" CAFs at that point. The meaning
112 of "live" here is the same as for live variables, see above (which is
113 why it's convenient to collect CAF information here rather than elsewhere).
115 The later SRT pass takes these lists of Ids and uses them to construct
116 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
120 Interaction of let-no-escape with SRTs [Sept 01]
121 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
124 let-no-escape x = ...caf1...caf2...
128 where caf1,caf2 are CAFs. Since x doesn't have a closure, we
129 build SRTs just as if x's defn was inlined at each call site, and
130 that means that x's CAF refs get duplicated in the overall SRT.
132 This is unlike ordinary lets, in which the CAF refs are not duplicated.
134 We could fix this loss of (static) sharing by making a sort of pseudo-closure
135 for x, solely to put in the SRTs lower down.
138 %************************************************************************
140 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
142 %************************************************************************
145 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
148 where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
150 coreExprToStg :: CoreExpr -> StgExpr
152 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
156 :: IdEnv HowBound -- environment for the bindings
158 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
160 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
161 coreTopBindsToStg env (b:bs)
162 = (env2, fvs2, b':bs')
164 -- env accumulates down the list of binds, fvs accumulates upwards
165 (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
166 (env2, fvs1, bs') = coreTopBindsToStg env1 bs
171 -> FreeVarsInfo -- Info about the body
173 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
175 coreTopBindToStg env body_fvs (NonRec id rhs)
177 (caf_info, upd) = hasCafRefs env rhs
178 env' = extendVarEnv env id how_bound
179 how_bound = LetBound (TopLet caf_info) (manifestArity rhs)
181 (stg_rhs, fvs', lv_info) =
183 coreToTopStgRhs body_fvs ((id,rhs), upd) `thenLne` \ (stg_rhs, fvs') ->
184 freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
185 returnLne (stg_rhs, fvs', lv_info)
188 bind = StgNonRec (mkSRT lv_info) id stg_rhs
190 ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
191 ASSERT2(consistent caf_info bind, ppr id)
192 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
193 (env', fvs' `unionFVInfo` body_fvs, bind)
195 coreTopBindToStg env body_fvs (Rec pairs)
197 (binders, rhss) = unzip pairs
199 -- To calculate caf_info, we initially map
200 -- all the binders to NoCafRefs
201 extra_env = [ (b, LetBound (TopLet NoCafRefs) (manifestArity rhs))
203 env1 = extendVarEnvList env extra_env
204 (caf_infos, upd_flags) = mapAndUnzip (hasCafRefs env1) rhss
205 -- NB: use env1 not env'
207 -- If any has a CAF ref, they all do
208 caf_info | any mayHaveCafRefs caf_infos = MayHaveCafRefs
209 | otherwise = NoCafRefs
211 extra_env' = [ (b, LetBound (TopLet caf_info) arity)
212 | (b, LetBound _ arity) <- extra_env ]
213 env' = extendVarEnvList env extra_env'
215 (stg_rhss, fvs', lv_info)
217 mapAndUnzipLne (coreToTopStgRhs body_fvs)
218 (pairs `zip` upd_flags) `thenLne` \ (stg_rhss, fvss') ->
219 let fvs' = unionFVInfos fvss' in
220 freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
221 returnLne (stg_rhss, fvs', lv_info)
224 bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
226 ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
227 ASSERT2(consistent caf_info bind, ppr binders)
228 -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
229 (env', fvs' `unionFVInfo` body_fvs, bind)
232 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
237 :: FreeVarsInfo -- Free var info for the scope of the binding
238 -> ((Id,CoreExpr), UpdateFlag)
239 -> LneM (StgRhs, FreeVarsInfo)
241 coreToTopStgRhs scope_fv_info ((bndr, rhs), upd)
242 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
243 returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs)
245 bndr_info = lookupFVInfo scope_fv_info bndr
247 mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo
250 mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body)
251 = StgRhsClosure noCCS binder_info
256 mkTopStgRhs ReEntrant rhs_fvs binder_info (StgConApp con args)
257 -- StgConApps can be Updatable: see isCrossDllConApp below
258 = StgRhsCon noCCS con args
260 mkTopStgRhs upd_flag rhs_fvs binder_info rhs
261 = StgRhsClosure noCCS binder_info
268 -- ---------------------------------------------------------------------------
270 -- ---------------------------------------------------------------------------
275 -> LneM (StgExpr, -- Decorated STG expr
276 FreeVarsInfo, -- Its free vars (NB free, not live)
277 EscVarsSet) -- Its escapees, a subset of its free vars;
278 -- also a subset of the domain of the envt
279 -- because we are only interested in the escapees
280 -- for vars which might be turned into
281 -- let-no-escaped ones.
284 The second and third components can be derived in a simple bottom up pass, not
285 dependent on any decisions about which variables will be let-no-escaped or
286 not. The first component, that is, the decorated expression, may then depend
287 on these components, but it in turn is not scrutinised as the basis for any
288 decisions. Hence no black holes.
291 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
292 coreToStgExpr (Var v) = coreToStgApp Nothing v []
294 coreToStgExpr expr@(App _ _)
295 = coreToStgApp Nothing f args
297 (f, args) = myCollectArgs expr
299 coreToStgExpr expr@(Lam _ _)
301 (args, body) = myCollectBinders expr
302 args' = filterStgBinders args
304 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
305 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
307 fvs = args' `minusFVBinders` body_fvs
308 escs = body_escs `delVarSetList` args'
309 result_expr | null args' = body
310 | otherwise = StgLam (exprType expr) args' body
312 returnLne (result_expr, fvs, escs)
314 coreToStgExpr (Note (SCC cc) expr)
315 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
316 returnLne (StgSCC cc expr2, fvs, escs) )
319 -- For ILX, convert (__coerce__ to_ty from_ty e)
320 -- into (coerce to_ty from_ty e)
321 -- where coerce is real function
322 coreToStgExpr (Note (Coerce to_ty from_ty) expr)
323 = coreToStgExpr (mkApps (Var unsafeCoerceId)
324 [Type from_ty, Type to_ty, expr])
327 coreToStgExpr (Note other_note expr)
330 -- Cases require a little more real work.
332 coreToStgExpr (Case scrut bndr alts)
333 = extendVarEnvLne [(bndr, LambdaBound)] (
334 mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
335 returnLne ( mkStgAlts (idType bndr) alts2,
337 unionVarSets escs_s )
338 ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
340 -- Determine whether the default binder is dead or not
341 -- This helps the code generator to avoid generating an assignment
342 -- for the case binder (is extremely rare cases) ToDo: remove.
343 bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
344 | otherwise = bndr `setIdOccInfo` IAmDead
346 -- Don't consider the default binder as being 'live in alts',
347 -- since this is from the point of view of the case expr, where
348 -- the default binder is not free.
349 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
350 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
353 freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
355 -- We tell the scrutinee that everything
356 -- live in the alts is live in it, too.
357 setVarsLiveInCont alts_lv_info (
358 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
359 freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
360 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
362 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
365 StgCase scrut2 (getLiveVars scrut_lv_info)
366 (getLiveVars alts_lv_info)
370 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
371 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
372 -- You might think we should have scrut_escs, not
373 -- (getFVSet scrut_fvs), but actually we can't call, and
374 -- then return from, a let-no-escape thing.
377 vars_alt (con, binders, rhs)
378 = let -- Remove type variables
379 binders' = filterStgBinders binders
381 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
382 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
384 -- Records whether each param is used in the RHS
385 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
387 returnLne ( (con, binders', good_use_mask, rhs2),
388 binders' `minusFVBinders` rhs_fvs,
389 rhs_escs `delVarSetList` binders' )
390 -- ToDo: remove the delVarSet;
391 -- since escs won't include any of these binders
394 Lets not only take quite a bit of work, but this is where we convert
395 then to let-no-escapes, if we wish.
397 (Meanwhile, we don't expect to see let-no-escapes...)
399 coreToStgExpr (Let bind body)
400 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
401 coreToStgLet no_binder_escapes bind body
402 ) `thenLne` \ (new_let, fvs, escs, _) ->
404 returnLne (new_let, fvs, escs)
408 mkStgAlts scrut_ty orig_alts
409 | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
410 | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
412 is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
414 prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
415 alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
418 = case orig_alts of -- DEFAULT is always first if it's there at all
419 (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
420 other -> (orig_alts, StgNoDefault)
422 maybe_tycon = case alg_alts of
423 -- Get the tycon from the data con
424 (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
426 -- Otherwise just do your best
427 [] -> case splitTyConApp_maybe (repType scrut_ty) of
428 Just (tc,_) | isAlgTyCon tc -> Just tc
433 -- ---------------------------------------------------------------------------
435 -- ---------------------------------------------------------------------------
439 :: Maybe UpdateFlag -- Just upd <=> this application is
440 -- the rhs of a thunk binding
441 -- x = [...] \upd [] -> the_app
442 -- with specified update flag
444 -> [CoreArg] -- Arguments
445 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
447 coreToStgApp maybe_thunk_body f args
448 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
449 lookupVarLne f `thenLne` \ how_bound ->
452 n_val_args = valArgCount args
453 not_letrec_bound = not (isLetBound how_bound)
455 = let fvs = singletonFVInfo f how_bound fun_occ in
456 -- e.g. (f :: a -> int) (x :: a)
457 -- Here the free variables are "f", "x" AND the type variable "a"
458 -- coreToStgArgs will deal with the arguments recursively
459 if opt_RuntimeTypes then
460 fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
463 -- Mostly, the arity info of a function is in the fn's IdInfo
464 -- But new bindings introduced by CoreSat may not have no
465 -- arity info; it would do us no good anyway. For example:
466 -- let f = \ab -> e in f
467 -- No point in having correct arity info for f!
468 -- Hence the hasArity stuff below.
469 -- NB: f_arity is only consulted for LetBound things
470 f_arity = stgArity f how_bound
471 saturated = f_arity <= n_val_args
474 | not_letrec_bound = noBinderInfo -- Uninteresting variable
475 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
476 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
479 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
480 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
481 -- saturated call doesn't escape
482 -- (let-no-escape applies to 'thunks' too)
484 | otherwise = unitVarSet f -- Inexact application; it does escape
486 -- At the moment of the call:
488 -- either the function is *not* let-no-escaped, in which case
489 -- nothing is live except live_in_cont
490 -- or the function *is* let-no-escaped in which case the
491 -- variables it uses are live, but still the function
492 -- itself is not. PS. In this case, the function's
493 -- live vars should already include those of the
494 -- continuation, but it does no harm to just union the
497 res_ty = exprType (mkApps (Var f) args)
498 app = case globalIdDetails f of
499 DataConWorkId dc | saturated -> StgConApp dc args'
500 PrimOpId op -> ASSERT( saturated )
501 StgOpApp (StgPrimOp op) args' res_ty
502 FCallId call -> ASSERT( saturated )
503 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
504 _other -> StgApp f args'
509 fun_fvs `unionFVInfo` args_fvs,
510 fun_escs `unionVarSet` (getFVSet args_fvs)
511 -- All the free vars of the args are disqualified
512 -- from being let-no-escaped.
517 -- ---------------------------------------------------------------------------
519 -- This is the guy that turns applications into A-normal form
520 -- ---------------------------------------------------------------------------
522 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
524 = returnLne ([], emptyFVInfo)
526 coreToStgArgs (Type ty : args) -- Type argument
527 = coreToStgArgs args `thenLne` \ (args', fvs) ->
528 if opt_RuntimeTypes then
529 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
531 returnLne (args', fvs)
533 coreToStgArgs (arg : args) -- Non-type argument
534 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
535 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
537 fvs = args_fvs `unionFVInfo` arg_fvs
538 stg_arg = case arg' of
539 StgApp v [] -> StgVarArg v
540 StgConApp con [] -> StgVarArg (dataConWorkId con)
541 StgLit lit -> StgLitArg lit
542 _ -> pprPanic "coreToStgArgs" (ppr arg)
544 returnLne (stg_arg : stg_args, fvs)
547 -- ---------------------------------------------------------------------------
548 -- The magic for lets:
549 -- ---------------------------------------------------------------------------
552 :: Bool -- True <=> yes, we are let-no-escaping this let
553 -> CoreBind -- bindings
555 -> LneM (StgExpr, -- new let
556 FreeVarsInfo, -- variables free in the whole let
557 EscVarsSet, -- variables that escape from the whole let
558 Bool) -- True <=> none of the binders in the bindings
559 -- is among the escaping vars
561 coreToStgLet let_no_escape bind body
562 = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
564 -- Do the bindings, setting live_in_cont to empty if
565 -- we ain't in a let-no-escape world
566 getVarsLiveInCont `thenLne` \ live_in_cont ->
567 setVarsLiveInCont (if let_no_escape
570 (vars_bind rec_body_fvs bind)
571 `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
574 extendVarEnvLne env_ext (
575 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
576 freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
578 returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
579 body2, body_fvs, body_escs, getLiveVars body_lv_info)
582 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
583 body2, body_fvs, body_escs, body_lvs) ->
586 -- Compute the new let-expression
588 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
589 | otherwise = StgLet bind2 body2
592 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
595 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
597 real_bind_escs = if let_no_escape then
601 -- Everything escapes which is free in the bindings
603 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
605 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
608 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
611 -- Debugging code as requested by Andrew Kennedy
612 checked_no_binder_escapes
613 | not no_binder_escapes && any is_join_var binders
614 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
616 | otherwise = no_binder_escapes
618 checked_no_binder_escapes = no_binder_escapes
621 -- Mustn't depend on the passed-in let_no_escape flag, since
622 -- no_binder_escapes is used by the caller to derive the flag!
628 checked_no_binder_escapes
631 set_of_binders = mkVarSet binders
632 binders = bindersOf bind
634 mk_binding bind_lv_info binder rhs
635 = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
637 live_vars | let_no_escape = addLiveVar bind_lv_info binder
638 | otherwise = unitLiveVar binder
639 -- c.f. the invariant on NestedLet
641 vars_bind :: FreeVarsInfo -- Free var info for body of binding
645 EscVarsSet, -- free vars; escapee vars
646 LiveInfo, -- Vars and CAFs live in binding
647 [(Id, HowBound)]) -- extension to environment
650 vars_bind body_fvs (NonRec binder rhs)
651 = coreToStgRhs body_fvs (binder,rhs)
652 `thenLne` \ (rhs2, bind_fvs, escs) ->
654 freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
656 env_ext_item = mk_binding bind_lv_info binder rhs
658 returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
659 bind_fvs, escs, bind_lv_info, [env_ext_item])
662 vars_bind body_fvs (Rec pairs)
663 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
665 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
666 binders = map fst pairs
667 env_ext = [ mk_binding bind_lv_info b rhs
670 extendVarEnvLne env_ext (
671 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs
672 `thenLne` \ (rhss2, fvss, escss) ->
674 bind_fvs = unionFVInfos fvss
675 escs = unionVarSets escss
677 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
678 `thenLne` \ bind_lv_info ->
680 returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
681 bind_fvs, escs, bind_lv_info, env_ext)
685 is_join_var :: Id -> Bool
686 -- A hack (used only for compiler debuggging) to tell if
687 -- a variable started life as a join point ($j)
688 is_join_var j = occNameUserString (getOccName j) == "$j"
692 coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
694 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
696 coreToStgRhs scope_fv_info (bndr, rhs)
697 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
698 getEnvLne `thenLne` \ env ->
699 returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs,
702 bndr_info = lookupFVInfo scope_fv_info bndr
704 mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
706 mkStgRhs env rhs_fvs binder_info (StgConApp con args)
707 = StgRhsCon noCCS con args
709 mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body)
710 = StgRhsClosure noCCS binder_info
715 mkStgRhs env rhs_fvs binder_info rhs
716 = StgRhsClosure noCCS binder_info
722 SDM: disabled. Eval/Apply can't handle functions with arity zero very
723 well; and making these into simple non-updatable thunks breaks other
724 assumptions (namely that they will be entered only once).
726 upd_flag | isPAP env rhs = ReEntrant
727 | otherwise = Updatable
731 upd = if isOnceDem dem
732 then (if isNotTop toplev
733 then SingleEntry -- HA! Paydirt for "dem"
736 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
740 -- For now we forbid SingleEntry CAFs; they tickle the
741 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
742 -- and I don't understand why. There's only one SE_CAF (well,
743 -- only one that tickled a great gaping bug in an earlier attempt
744 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
745 -- specifically Main.lvl6 in spectral/cryptarithm2.
746 -- So no great loss. KSW 2000-07.
750 Detect thunks which will reduce immediately to PAPs, and make them
751 non-updatable. This has several advantages:
753 - the non-updatable thunk behaves exactly like the PAP,
755 - the thunk is more efficient to enter, because it is
756 specialised to the task.
758 - we save one update frame, one stg_update_PAP, one update
759 and lots of PAP_enters.
761 - in the case where the thunk is top-level, we save building
762 a black hole and futhermore the thunk isn't considered to
763 be a CAF any more, so it doesn't appear in any SRTs.
765 We do it here, because the arity information is accurate, and we need
766 to do it before the SRT pass to save the SRT entries associated with
770 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
772 arity = stgArity f (lookupBinding env f)
777 %************************************************************************
779 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
781 %************************************************************************
783 There's a lot of stuff to pass around, so we use this @LneM@ monad to
784 help. All the stuff here is only passed *down*.
787 type LneM a = IdEnv HowBound
788 -> LiveInfo -- Vars and CAFs live in continuation
791 type LiveInfo = (StgLiveVars, -- Dynamic live variables;
792 -- i.e. ones with a nested (non-top-level) binding
793 CafSet) -- Static live variables;
794 -- i.e. top-level variables that are CAFs or refer to them
796 type EscVarsSet = IdSet
800 = ImportBound -- Used only as a response to lookupBinding; never
801 -- exists in the range of the (IdEnv HowBound)
803 | LetBound -- A let(rec) in this module
804 LetInfo -- Whether top level or nested
805 Arity -- Its arity (local Ids don't have arity info at this point)
807 | LambdaBound -- Used for both lambda and case
809 data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live?
810 -- Invariant: the binder itself is always a member of
811 -- the dynamic set of its own LiveInfo
813 | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one?
815 isLetBound (LetBound _ _) = True
816 isLetBound other = False
818 topLevelBound ImportBound = True
819 topLevelBound (LetBound (TopLet _) _) = True
820 topLevelBound other = False
823 For a let(rec)-bound variable, x, we record LiveInfo, the set of
824 variables that are live if x is live. This LiveInfo comprises
825 (a) dynamic live variables (ones with a non-top-level binding)
826 (b) static live variabes (CAFs or things that refer to CAFs)
828 For "normal" variables (a) is just x alone. If x is a let-no-escaped
829 variable then x is represented by a code pointer and a stack pointer
830 (well, one for each stack). So all of the variables needed in the
831 execution of x are live if x is, and are therefore recorded in the
832 LetBound constructor; x itself *is* included.
834 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
838 emptyLiveInfo :: LiveInfo
839 emptyLiveInfo = (emptyVarSet,emptyVarSet)
841 unitLiveVar :: Id -> LiveInfo
842 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
844 unitLiveCaf :: Id -> LiveInfo
845 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
847 addLiveVar :: LiveInfo -> Id -> LiveInfo
848 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
850 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
851 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
853 mkSRT :: LiveInfo -> SRT
854 mkSRT (_, cafs) = SRTEntries cafs
856 getLiveVars :: LiveInfo -> StgLiveVars
857 getLiveVars (lvs, _) = lvs
861 The std monad functions:
863 initLne :: IdEnv HowBound -> LneM a -> a
864 initLne env m = m env emptyLiveInfo
868 {-# INLINE thenLne #-}
869 {-# INLINE returnLne #-}
871 returnLne :: a -> LneM a
872 returnLne e env lvs_cont = e
874 thenLne :: LneM a -> (a -> LneM b) -> LneM b
875 thenLne m k env lvs_cont
876 = k (m env lvs_cont) env lvs_cont
878 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
879 mapLne f [] = returnLne []
881 = f x `thenLne` \ r ->
882 mapLne f xs `thenLne` \ rs ->
885 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
887 mapAndUnzipLne f [] = returnLne ([],[])
888 mapAndUnzipLne f (x:xs)
889 = f x `thenLne` \ (r1, r2) ->
890 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
891 returnLne (r1:rs1, r2:rs2)
893 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
895 mapAndUnzip3Lne f [] = returnLne ([],[],[])
896 mapAndUnzip3Lne f (x:xs)
897 = f x `thenLne` \ (r1, r2, r3) ->
898 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
899 returnLne (r1:rs1, r2:rs2, r3:rs3)
901 fixLne :: (a -> LneM a) -> LneM a
902 fixLne expr env lvs_cont
905 result = expr result env lvs_cont
908 Functions specific to this monad:
911 getVarsLiveInCont :: LneM LiveInfo
912 getVarsLiveInCont env lvs_cont = lvs_cont
914 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
915 setVarsLiveInCont new_lvs_cont expr env lvs_cont
916 = expr env new_lvs_cont
918 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
919 extendVarEnvLne ids_w_howbound expr env lvs_cont
920 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
922 lookupVarLne :: Id -> LneM HowBound
923 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
925 getEnvLne :: LneM (IdEnv HowBound)
926 getEnvLne env lvs_cont = returnLne env env lvs_cont
928 lookupBinding :: IdEnv HowBound -> Id -> HowBound
929 lookupBinding env v = case lookupVarEnv env v of
931 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
934 -- The result of lookupLiveVarsForSet, a set of live variables, is
935 -- only ever tacked onto a decorated expression. It is never used as
936 -- the basis of a control decision, which might give a black hole.
938 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
939 freeVarsToLiveVars fvs env live_in_cont
940 = returnLne live_info env live_in_cont
942 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
943 lvs_from_fvs = map do_one (allFreeIds fvs)
945 do_one (v, how_bound)
947 ImportBound -> unitLiveCaf v -- Only CAF imports are
949 LetBound (TopLet caf_info) _
950 | mayHaveCafRefs caf_info -> unitLiveCaf v
951 | otherwise -> emptyLiveInfo
953 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
954 -- (see the invariant on NestedLet)
956 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
959 %************************************************************************
961 \subsection[Free-var info]{Free variable information}
963 %************************************************************************
966 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
967 -- The Var is so we can gather up the free variables
970 -- The HowBound info just saves repeated lookups;
971 -- we look up just once when we encounter the occurrence.
972 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
973 -- Imported Ids without CAF refs are simply
974 -- not put in the FreeVarsInfo for an expression.
975 -- See singletonFVInfo and freeVarsToLiveVars
977 -- StgBinderInfo records how it occurs; notably, we
978 -- are interested in whether it only occurs in saturated
979 -- applications, because then we don't need to build a
981 -- If f is mapped to noBinderInfo, that means
982 -- that f *is* mentioned (else it wouldn't be in the
983 -- IdEnv at all), but perhaps in an unsaturated applications.
985 -- All case/lambda-bound things are also mapped to
986 -- noBinderInfo, since we aren't interested in their
989 -- For ILX we track free var info for type variables too;
990 -- hence VarEnv not IdEnv
994 emptyFVInfo :: FreeVarsInfo
995 emptyFVInfo = emptyVarEnv
997 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
998 -- Don't record non-CAF imports at all, to keep free-var sets small
999 singletonFVInfo id ImportBound info
1000 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1001 | otherwise = emptyVarEnv
1002 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
1004 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
1005 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
1007 add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
1008 -- Type variables must be lambda-bound
1010 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1011 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1013 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1014 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1016 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1017 minusFVBinders vs fv = foldr minusFVBinder fv vs
1019 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1020 minusFVBinder v fv | isId v && opt_RuntimeTypes
1021 = (fv `delVarEnv` v) `unionFVInfo`
1022 tyvarFVInfo (tyVarsOfType (idType v))
1023 | otherwise = fv `delVarEnv` v
1024 -- When removing a binder, remember to add its type variables
1025 -- c.f. CoreFVs.delBinderFV
1027 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1028 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1030 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1031 -- Find how the given Id is used.
1032 -- Externally visible things may be used any old how
1034 | isExternalName (idName id) = noBinderInfo
1035 | otherwise = case lookupVarEnv fvs id of
1036 Nothing -> noBinderInfo
1037 Just (_,_,info) -> info
1039 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1040 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1042 -- Non-top-level things only, both type variables and ids
1043 -- (type variables only if opt_RuntimeTypes)
1044 getFVs :: FreeVarsInfo -> [Var]
1045 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1046 not (topLevelBound how_bound) ]
1048 getFVSet :: FreeVarsInfo -> VarSet
1049 getFVSet fvs = mkVarSet (getFVs fvs)
1051 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1052 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1053 (id1, hb1, combineStgBinderInfo info1 info2)
1056 -- The HowBound info for a variable in the FVInfo should be consistent
1057 check_eq_how_bound ImportBound ImportBound = True
1058 check_eq_how_bound LambdaBound LambdaBound = True
1059 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1060 check_eq_how_bound hb1 hb2 = False
1062 check_eq_li (NestedLet _) (NestedLet _) = True
1063 check_eq_li (TopLet _) (TopLet _) = True
1064 check_eq_li li1 li2 = False
1070 filterStgBinders :: [Var] -> [Var]
1071 filterStgBinders bndrs
1072 | opt_RuntimeTypes = bndrs
1073 | otherwise = filter isId bndrs
1078 -- Ignore all notes except SCC
1079 myCollectBinders expr
1082 go bs (Lam b e) = go (b:bs) e
1083 go bs e@(Note (SCC _) _) = (reverse bs, e)
1084 go bs (Note _ e) = go bs e
1085 go bs e = (reverse bs, e)
1087 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1088 -- We assume that we only have variables
1089 -- in the function position by now
1093 go (Var v) as = (v, as)
1094 go (App f a) as = go f (a:as)
1095 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1096 go (Note n e) as = go e as
1097 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1100 %************************************************************************
1102 \subsection{Figuring out CafInfo for an expression}
1104 %************************************************************************
1106 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1107 We mark such things as `MayHaveCafRefs' because this information is
1108 used to decide whether a particular closure needs to be referenced
1111 There are two reasons for setting MayHaveCafRefs:
1112 a) The RHS is a CAF: a top-level updatable thunk.
1113 b) The RHS refers to something that MayHaveCafRefs
1115 Possible improvement: In an effort to keep the number of CAFs (and
1116 hence the size of the SRTs) down, we could also look at the expression and
1117 decide whether it requires a small bounded amount of heap, so we can ignore
1118 it as a CAF. In these cases however, we would need to use an additional
1119 CAF list to keep track of non-collectable CAFs.
1122 hasCafRefs :: IdEnv HowBound -> CoreExpr -> (CafInfo, UpdateFlag)
1124 | is_caf || mentions_cafs = (MayHaveCafRefs, upd_flag)
1125 | otherwise = (NoCafRefs, ReEntrant)
1127 mentions_cafs = isFastTrue (cafRefs p expr)
1128 is_caf = not (rhsIsNonUpd p expr)
1129 upd_flag | is_caf = Updatable
1130 | otherwise = ReEntrant
1132 -- The environment that cafRefs uses has top-level bindings *only*.
1133 -- We don't bother to add local bindings as cafRefs traverses the expression
1134 -- because they will all be for LocalIds (all nested things are LocalIds)
1135 -- However, we must look in the env first, because some top level things
1136 -- might be local Ids
1139 = case lookupVarEnv p id of
1140 Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info)
1141 Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
1142 | otherwise -> fastBool False -- Nested binder
1143 _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
1145 cafRefs p (Lit l) = fastBool False
1146 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1147 cafRefs p (Lam x e) = cafRefs p e
1148 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1149 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
1150 cafRefs p (Note n e) = cafRefs p e
1151 cafRefs p (Type t) = fastBool False
1153 cafRefss p [] = fastBool False
1154 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1156 -- hack for lazy-or over FastBool.
1157 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1160 rhsIsNonUpd :: IdEnv HowBound -> CoreExpr -> Bool
1161 -- True => Value-lambda, constructor, PAP
1162 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1163 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1165 -- b) (C x xs), where C is a contructors is updatable if the application is
1166 -- dynamic: see isDynConApp
1168 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1170 -- This function has to line up with what the update flag
1171 -- for the StgRhs gets set to in mkStgRhs (above)
1173 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1174 -- them as making the RHS re-entrant (non-updatable).
1175 rhsIsNonUpd p (Lam b e) = isRuntimeVar b || rhsIsNonUpd p e
1176 rhsIsNonUpd p (Note (SCC _) e) = False
1177 rhsIsNonUpd p (Note _ e) = rhsIsNonUpd p e
1178 rhsIsNonUpd p other_expr
1179 = go other_expr 0 []
1181 go (Var f) n_args args = idAppIsNonUpd p f n_args args
1183 go (App f a) n_args args
1184 | isTypeArg a = go f n_args args
1185 | otherwise = go f (n_args + 1) (a:args)
1187 go (Note (SCC _) f) n_args args = False
1188 go (Note _ f) n_args args = go f n_args args
1190 go other n_args args = False
1192 idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool
1193 idAppIsNonUpd p id n_val_args args
1194 | Just con <- isDataConWorkId_maybe id = not (isCrossDllConApp con args)
1195 | otherwise = False -- SDM: disbled. See comment with isPAP above.
1196 -- n_val_args < stgArity id (lookupBinding p id)
1198 stgArity :: Id -> HowBound -> Arity
1199 stgArity f (LetBound _ arity) = arity
1200 stgArity f ImportBound = idArity f
1201 stgArity f LambdaBound = 0
1203 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1204 isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
1205 -- Top-level constructor applications can usually be allocated
1206 -- statically, but they can't if
1207 -- a) the constructor, or any of the arguments, come from another DLL
1208 -- b) any of the arguments are LitLits
1209 -- (because we can't refer to static labels in other DLLs).
1210 -- If this happens we simply make the RHS into an updatable thunk,
1211 -- and 'exectute' it rather than allocating it statically.
1212 -- All this should match the decision in (see CoreToStg.mkStgRhs)
1215 isCrossDllArg :: CoreExpr -> Bool
1216 -- True if somewhere in the expression there's a cross-DLL reference
1217 isCrossDllArg (Type _) = False
1218 isCrossDllArg (Var v) = isDllName (idName v)
1219 isCrossDllArg (Note _ e) = isCrossDllArg e
1220 isCrossDllArg (Lit lit) = isLitLitLit lit
1221 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
1222 isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam