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 )
25 import CostCentre ( noCCS )
28 import DataCon ( dataConWrapId )
29 import IdInfo ( OccInfo(..) )
30 import Maybes ( maybeToBool )
31 import Name ( getOccName, isExternallyVisibleName, isDllName )
32 import OccName ( occNameUserString )
33 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
34 import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
35 import FastTypes hiding ( fastOr )
41 %************************************************************************
43 \subsection[live-vs-free-doc]{Documentation}
45 %************************************************************************
47 (There is other relevant documentation in codeGen/CgLetNoEscape.)
49 The actual Stg datatype is decorated with {\em live variable}
50 information, as well as {\em free variable} information. The two are
51 {\em not} the same. Liveness is an operational property rather than a
52 semantic one. A variable is live at a particular execution point if
53 it can be referred to {\em directly} again. In particular, a dead
54 variable's stack slot (if it has one):
57 should be stubbed to avoid space leaks, and
59 may be reused for something else.
62 There ought to be a better way to say this. Here are some examples:
69 Just after the `in', v is live, but q is dead. If the whole of that
70 let expression was enclosed in a case expression, thus:
72 case (let v = [q] \[x] -> e in ...v...) of
75 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
76 we'll return later to the @alts@ and need it.
78 Let-no-escapes make this a bit more interesting:
80 let-no-escape v = [q] \ [x] -> e
84 Here, @q@ is still live at the `in', because @v@ is represented not by
85 a closure but by the current stack state. In other words, if @v@ is
86 live then so is @q@. Furthermore, if @e@ mentions an enclosing
87 let-no-escaped variable, then {\em its} free variables are also live
90 %************************************************************************
92 \subsection[caf-info]{Collecting live CAF info}
94 %************************************************************************
96 In this pass we also collect information on which CAFs are live for
97 constructing SRTs (see SRT.lhs).
99 A top-level Id has CafInfo, which is
101 - MayHaveCafRefs, if it may refer indirectly to
103 - NoCafRefs if it definitely doesn't
105 we collect the CafInfo first by analysing the original Core expression, and
106 also place this information in the environment.
108 During CoreToStg, we then pin onto each binding and case expression, a
109 list of Ids which represents the "live" CAFs at that point. The meaning
110 of "live" here is the same as for live variables, see above (which is
111 why it's convenient to collect CAF information here rather than elsewhere).
113 The later SRT pass takes these lists of Ids and uses them to construct
114 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
118 Interaction of let-no-escape with SRTs [Sept 01]
119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
122 let-no-escape x = ...caf1...caf2...
126 where caf1,caf2 are CAFs. Since x doesn't have a closure, we
127 build SRTs just as if x's defn was inlined at each call site, and
128 that means that x's CAF refs get duplicated in the overall SRT.
130 This is unlike ordinary lets, in which the CAF refs are not duplicated.
132 We could fix this loss of (static) sharing by making a sort of pseudo-closure
133 for x, solely to put in the SRTs lower down.
136 %************************************************************************
138 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
140 %************************************************************************
143 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
146 where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
148 coreExprToStg :: CoreExpr -> StgExpr
150 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
154 :: IdEnv HowBound -- environment for the bindings
156 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
158 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
159 coreTopBindsToStg env (b:bs)
160 = (env2, fvs2, b':bs')
162 -- env accumulates down the list of binds, fvs accumulates upwards
163 (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
164 (env2, fvs1, bs') = coreTopBindsToStg env1 bs
169 -> FreeVarsInfo -- Info about the body
171 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
173 coreTopBindToStg env body_fvs (NonRec id rhs)
175 caf_info = hasCafRefs env rhs
176 env' = extendVarEnv env id how_bound
177 how_bound = LetBound (TopLet caf_info) (predictArity rhs)
179 (stg_rhs, fvs', lv_info) =
181 coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) ->
182 freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
183 returnLne (stg_rhs, fvs', lv_info)
186 bind = StgNonRec (mkSRT lv_info) id stg_rhs
188 ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
189 ASSERT2(consistent caf_info bind, ppr id)
190 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
191 (env', fvs' `unionFVInfo` body_fvs, bind)
193 coreTopBindToStg env body_fvs (Rec pairs)
195 (binders, rhss) = unzip pairs
197 -- To calculate caf_info, we initially map
198 -- all the binders to NoCafRefs
199 env1 = extendVarEnvList env
200 [ (b, LetBound (TopLet NoCafRefs) (error "no arity"))
203 caf_info = hasCafRefss env1{-NB: not env'-} rhss
205 env' = extendVarEnvList env
206 [ (b, LetBound (TopLet caf_info) (predictArity rhs))
209 (stg_rhss, fvs', lv_info)
211 mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
212 `thenLne` \ (stg_rhss, fvss', _) ->
213 let fvs' = unionFVInfos fvss' in
214 freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
215 returnLne (stg_rhss, fvs', lv_info)
218 bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
220 ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
221 ASSERT2(consistent caf_info bind, ppr binders)
222 -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
223 (env', fvs' `unionFVInfo` body_fvs, bind)
226 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
231 :: FreeVarsInfo -- Free var info for the scope of the binding
234 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
236 coreToStgRhs scope_fv_info top (binder, rhs)
237 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
238 returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
241 binder_info = lookupFVInfo scope_fv_info binder
243 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
246 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
247 = StgRhsClosure noCCS binder_info
252 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
253 | isNotTopLevel top || not (isDllConApp con args)
254 = StgRhsCon noCCS con args
256 mkStgRhs top rhs_fvs binder_info rhs
257 = StgRhsClosure noCCS binder_info
262 updatable args body | null args && isPAP body = ReEntrant
263 | otherwise = Updatable
265 upd = if isOnceDem dem
266 then (if isNotTop toplev
267 then SingleEntry -- HA! Paydirt for "dem"
270 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
274 -- For now we forbid SingleEntry CAFs; they tickle the
275 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
276 -- and I don't understand why. There's only one SE_CAF (well,
277 -- only one that tickled a great gaping bug in an earlier attempt
278 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
279 -- specifically Main.lvl6 in spectral/cryptarithm2.
280 -- So no great loss. KSW 2000-07.
284 Detect thunks which will reduce immediately to PAPs, and make them
285 non-updatable. This has several advantages:
287 - the non-updatable thunk behaves exactly like the PAP,
289 - the thunk is more efficient to enter, because it is
290 specialised to the task.
292 - we save one update frame, one stg_update_PAP, one update
293 and lots of PAP_enters.
295 - in the case where the thunk is top-level, we save building
296 a black hole and futhermore the thunk isn't considered to
297 be a CAF any more, so it doesn't appear in any SRTs.
299 We do it here, because the arity information is accurate, and we need
300 to do it before the SRT pass to save the SRT entries associated with
304 isPAP (StgApp f args) = idArity f > length args
309 -- ---------------------------------------------------------------------------
311 -- ---------------------------------------------------------------------------
316 -> LneM (StgExpr, -- Decorated STG expr
317 FreeVarsInfo, -- Its free vars (NB free, not live)
318 EscVarsSet) -- Its escapees, a subset of its free vars;
319 -- also a subset of the domain of the envt
320 -- because we are only interested in the escapees
321 -- for vars which might be turned into
322 -- let-no-escaped ones.
325 The second and third components can be derived in a simple bottom up pass, not
326 dependent on any decisions about which variables will be let-no-escaped or
327 not. The first component, that is, the decorated expression, may then depend
328 on these components, but it in turn is not scrutinised as the basis for any
329 decisions. Hence no black holes.
332 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
333 coreToStgExpr (Var v) = coreToStgApp Nothing v []
335 coreToStgExpr expr@(App _ _)
336 = coreToStgApp Nothing f args
338 (f, args) = myCollectArgs expr
340 coreToStgExpr expr@(Lam _ _)
342 (args, body) = myCollectBinders expr
343 args' = filterStgBinders args
345 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
346 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
348 fvs = args' `minusFVBinders` body_fvs
349 escs = body_escs `delVarSetList` args'
350 result_expr | null args' = body
351 | otherwise = StgLam (exprType expr) args' body
353 returnLne (result_expr, fvs, escs)
355 coreToStgExpr (Note (SCC cc) expr)
356 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
357 returnLne (StgSCC cc expr2, fvs, escs) )
359 coreToStgExpr (Note other_note expr)
362 -- Cases require a little more real work.
364 coreToStgExpr (Case scrut bndr alts)
365 = extendVarEnvLne [(bndr, LambdaBound)] (
366 mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
367 returnLne ( mkStgAlts (idType bndr) alts2,
369 unionVarSets escs_s )
370 ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
372 -- Determine whether the default binder is dead or not
373 -- This helps the code generator to avoid generating an assignment
374 -- for the case binder (is extremely rare cases) ToDo: remove.
375 bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
376 | otherwise = bndr `setIdOccInfo` IAmDead
378 -- Don't consider the default binder as being 'live in alts',
379 -- since this is from the point of view of the case expr, where
380 -- the default binder is not free.
381 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
382 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
385 freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
387 -- We tell the scrutinee that everything
388 -- live in the alts is live in it, too.
389 setVarsLiveInCont alts_lv_info (
390 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
391 freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
392 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
394 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
397 StgCase scrut2 (getLiveVars scrut_lv_info)
398 (getLiveVars alts_lv_info)
402 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
403 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
404 -- You might think we should have scrut_escs, not
405 -- (getFVSet scrut_fvs), but actually we can't call, and
406 -- then return from, a let-no-escape thing.
409 vars_alt (con, binders, rhs)
410 = let -- Remove type variables
411 binders' = filterStgBinders binders
413 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
414 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
416 -- Records whether each param is used in the RHS
417 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
419 returnLne ( (con, binders', good_use_mask, rhs2),
420 binders' `minusFVBinders` rhs_fvs,
421 rhs_escs `delVarSetList` binders' )
422 -- ToDo: remove the delVarSet;
423 -- since escs won't include any of these binders
426 Lets not only take quite a bit of work, but this is where we convert
427 then to let-no-escapes, if we wish.
429 (Meanwhile, we don't expect to see let-no-escapes...)
431 coreToStgExpr (Let bind body)
432 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
433 coreToStgLet no_binder_escapes bind body
434 ) `thenLne` \ (new_let, fvs, escs, _) ->
436 returnLne (new_let, fvs, escs)
440 mkStgAlts scrut_ty orig_alts
441 | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt
442 | otherwise = StgAlgAlts maybe_tycon alg_alts deflt
444 is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
446 prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts]
447 alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts]
450 = case orig_alts of -- DEFAULT is always first if it's there at all
451 (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs)
452 other -> (orig_alts, StgNoDefault)
454 maybe_tycon = case alg_alts of
455 -- Get the tycon from the data con
456 (dc, _, _, _) : _rest -> Just (dataConTyCon dc)
458 -- Otherwise just do your best
459 [] -> case splitTyConApp_maybe (repType scrut_ty) of
460 Just (tc,_) | isAlgTyCon tc -> Just tc
465 -- ---------------------------------------------------------------------------
467 -- ---------------------------------------------------------------------------
471 :: Maybe UpdateFlag -- Just upd <=> this application is
472 -- the rhs of a thunk binding
473 -- x = [...] \upd [] -> the_app
474 -- with specified update flag
476 -> [CoreArg] -- Arguments
477 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
479 coreToStgApp maybe_thunk_body f args
480 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
481 lookupVarLne f `thenLne` \ how_bound ->
484 n_val_args = valArgCount args
485 not_letrec_bound = not (isLetBound how_bound)
487 = let fvs = singletonFVInfo f how_bound fun_occ in
488 -- e.g. (f :: a -> int) (x :: a)
489 -- Here the free variables are "f", "x" AND the type variable "a"
490 -- coreToStgArgs will deal with the arguments recursively
491 if opt_RuntimeTypes then
492 fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
495 -- Mostly, the arity info of a function is in the fn's IdInfo
496 -- But new bindings introduced by CoreSat may not have no
497 -- arity info; it would do us no good anyway. For example:
498 -- let f = \ab -> e in f
499 -- No point in having correct arity info for f!
500 -- Hence the hasArity stuff below.
501 -- NB: f_arity is only consulted for LetBound things
502 f_arity = case how_bound of
503 LetBound _ arity -> arity
506 | not_letrec_bound = noBinderInfo -- Uninteresting variable
507 | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
508 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
511 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
512 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
513 -- saturated call doesn't escape
514 -- (let-no-escape applies to 'thunks' too)
516 | otherwise = unitVarSet f -- Inexact application; it does escape
518 -- At the moment of the call:
520 -- either the function is *not* let-no-escaped, in which case
521 -- nothing is live except live_in_cont
522 -- or the function *is* let-no-escaped in which case the
523 -- variables it uses are live, but still the function
524 -- itself is not. PS. In this case, the function's
525 -- live vars should already include those of the
526 -- continuation, but it does no harm to just union the
529 res_ty = exprType (mkApps (Var f) args)
530 app = case globalIdDetails f of
531 DataConId dc -> StgConApp dc args'
532 PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
533 FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
534 _other -> StgApp f args'
539 fun_fvs `unionFVInfo` args_fvs,
540 fun_escs `unionVarSet` (getFVSet args_fvs)
541 -- All the free vars of the args are disqualified
542 -- from being let-no-escaped.
547 -- ---------------------------------------------------------------------------
549 -- This is the guy that turns applications into A-normal form
550 -- ---------------------------------------------------------------------------
552 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
554 = returnLne ([], emptyFVInfo)
556 coreToStgArgs (Type ty : args) -- Type argument
557 = coreToStgArgs args `thenLne` \ (args', fvs) ->
558 if opt_RuntimeTypes then
559 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
561 returnLne (args', fvs)
563 coreToStgArgs (arg : args) -- Non-type argument
564 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
565 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
567 fvs = args_fvs `unionFVInfo` arg_fvs
568 stg_arg = case arg' of
569 StgApp v [] -> StgVarArg v
570 StgConApp con [] -> StgVarArg (dataConWrapId con)
571 StgLit lit -> StgLitArg lit
572 _ -> pprPanic "coreToStgArgs" (ppr arg)
574 returnLne (stg_arg : stg_args, fvs)
577 -- ---------------------------------------------------------------------------
578 -- The magic for lets:
579 -- ---------------------------------------------------------------------------
582 :: Bool -- True <=> yes, we are let-no-escaping this let
583 -> CoreBind -- bindings
585 -> LneM (StgExpr, -- new let
586 FreeVarsInfo, -- variables free in the whole let
587 EscVarsSet, -- variables that escape from the whole let
588 Bool) -- True <=> none of the binders in the bindings
589 -- is among the escaping vars
591 coreToStgLet let_no_escape bind body
592 = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
594 -- Do the bindings, setting live_in_cont to empty if
595 -- we ain't in a let-no-escape world
596 getVarsLiveInCont `thenLne` \ live_in_cont ->
597 setVarsLiveInCont (if let_no_escape
600 (vars_bind rec_body_fvs bind)
601 `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
604 extendVarEnvLne env_ext (
605 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
606 freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
608 returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
609 body2, body_fvs, body_escs, getLiveVars body_lv_info)
612 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
613 body2, body_fvs, body_escs, body_lvs) ->
616 -- Compute the new let-expression
618 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
619 | otherwise = StgLet bind2 body2
622 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
625 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
627 real_bind_escs = if let_no_escape then
631 -- Everything escapes which is free in the bindings
633 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
635 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
638 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
641 -- Debugging code as requested by Andrew Kennedy
642 checked_no_binder_escapes
643 | not no_binder_escapes && any is_join_var binders
644 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
646 | otherwise = no_binder_escapes
648 checked_no_binder_escapes = no_binder_escapes
651 -- Mustn't depend on the passed-in let_no_escape flag, since
652 -- no_binder_escapes is used by the caller to derive the flag!
658 checked_no_binder_escapes
661 set_of_binders = mkVarSet binders
662 binders = bindersOf bind
664 mk_binding bind_lv_info binder rhs
665 = (binder, LetBound (NestedLet live_vars) (predictArity rhs))
667 live_vars | let_no_escape = addLiveVar bind_lv_info binder
668 | otherwise = unitLiveVar binder
669 -- c.f. the invariant on NestedLet
671 vars_bind :: FreeVarsInfo -- Free var info for body of binding
675 EscVarsSet, -- free vars; escapee vars
676 LiveInfo, -- Vars and CAFs live in binding
677 [(Id, HowBound)]) -- extension to environment
680 vars_bind body_fvs (NonRec binder rhs)
681 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
682 `thenLne` \ (rhs2, bind_fvs, escs) ->
684 freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
686 env_ext_item = mk_binding bind_lv_info binder rhs
688 returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
689 bind_fvs, escs, bind_lv_info, [env_ext_item])
692 vars_bind body_fvs (Rec pairs)
693 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
695 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
696 binders = map fst pairs
697 env_ext = [ mk_binding bind_lv_info b rhs
700 extendVarEnvLne env_ext (
701 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
702 `thenLne` \ (rhss2, fvss, escss) ->
704 bind_fvs = unionFVInfos fvss
705 escs = unionVarSets escss
707 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
708 `thenLne` \ bind_lv_info ->
710 returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
711 bind_fvs, escs, bind_lv_info, env_ext)
715 is_join_var :: Id -> Bool
716 -- A hack (used only for compiler debuggging) to tell if
717 -- a variable started life as a join point ($j)
718 is_join_var j = occNameUserString (getOccName j) == "$j"
721 %************************************************************************
723 \subsection{Arity prediction}
725 %************************************************************************
727 To avoid yet another knot, we predict the arity of each function from
728 its Core form, based on the number of visible top-level lambdas.
729 It should be the same as the arity of the STG RHS!
732 predictArity :: CoreExpr -> Int
733 predictArity (Lam x e)
734 | isTyVar x = predictArity e
735 | otherwise = 1 + predictArity e
736 predictArity (Note _ e)
737 -- Ignore coercions. Top level sccs are removed by the final
738 -- profiling pass, so we ignore those too.
744 %************************************************************************
746 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
748 %************************************************************************
750 There's a lot of stuff to pass around, so we use this @LneM@ monad to
751 help. All the stuff here is only passed *down*.
754 type LneM a = IdEnv HowBound
755 -> LiveInfo -- Vars and CAFs live in continuation
758 type LiveInfo = (StgLiveVars, -- Dynamic live variables;
759 -- i.e. ones with a nested (non-top-level) binding
760 CafSet) -- Static live variables;
761 -- i.e. top-level variables that are CAFs or refer to them
763 type EscVarsSet = IdSet
767 = ImportBound -- Used only as a response to lookupBinding; never
768 -- exists in the range of the (IdEnv HowBound)
770 | LetBound -- A let(rec) in this module
771 LetInfo -- Whether top level or nested
772 Arity -- Its arity (local Ids don't have arity info at this point)
774 | LambdaBound -- Used for both lambda and case
776 data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live?
777 -- Invariant: the binder itself is always a member of
778 -- the dynamic set of its own LiveInfo
779 | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one?
781 isLetBound (LetBound _ _) = True
782 isLetBound other = False
784 topLevelBound ImportBound = True
785 topLevelBound (LetBound (TopLet _) _) = True
786 topLevelBound other = False
789 For a let(rec)-bound variable, x, we record LiveInfo, the set of
790 variables that are live if x is live. This LiveInfo comprises
791 (a) dynamic live variables (ones with a non-top-level binding)
792 (b) static live variabes (CAFs or things that refer to CAFs)
794 For "normal" variables (a) is just x alone. If x is a let-no-escaped
795 variable then x is represented by a code pointer and a stack pointer
796 (well, one for each stack). So all of the variables needed in the
797 execution of x are live if x is, and are therefore recorded in the
798 LetBound constructor; x itself *is* included.
800 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
804 emptyLiveInfo :: LiveInfo
805 emptyLiveInfo = (emptyVarSet,emptyVarSet)
807 unitLiveVar :: Id -> LiveInfo
808 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
810 unitLiveCaf :: Id -> LiveInfo
811 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
813 addLiveVar :: LiveInfo -> Id -> LiveInfo
814 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
816 deleteLiveVar :: LiveInfo -> Id -> LiveInfo
817 deleteLiveVar (lvs, cafs) id = (lvs `delVarSet` id, cafs)
819 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
820 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
822 unionLiveInfos :: [LiveInfo] -> LiveInfo
823 unionLiveInfos lvs = foldr unionLiveInfo emptyLiveInfo lvs
825 mkSRT :: LiveInfo -> SRT
826 mkSRT (_, cafs) = SRTEntries cafs
828 getLiveVars :: LiveInfo -> StgLiveVars
829 getLiveVars (lvs, _) = lvs
833 The std monad functions:
835 initLne :: IdEnv HowBound -> LneM a -> a
836 initLne env m = m env emptyLiveInfo
840 {-# INLINE thenLne #-}
841 {-# INLINE returnLne #-}
843 returnLne :: a -> LneM a
844 returnLne e env lvs_cont = e
846 thenLne :: LneM a -> (a -> LneM b) -> LneM b
847 thenLne m k env lvs_cont
848 = k (m env lvs_cont) env lvs_cont
850 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
851 mapLne f [] = returnLne []
853 = f x `thenLne` \ r ->
854 mapLne f xs `thenLne` \ rs ->
857 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
859 mapAndUnzipLne f [] = returnLne ([],[])
860 mapAndUnzipLne f (x:xs)
861 = f x `thenLne` \ (r1, r2) ->
862 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
863 returnLne (r1:rs1, r2:rs2)
865 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
867 mapAndUnzip3Lne f [] = returnLne ([],[],[])
868 mapAndUnzip3Lne f (x:xs)
869 = f x `thenLne` \ (r1, r2, r3) ->
870 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
871 returnLne (r1:rs1, r2:rs2, r3:rs3)
873 fixLne :: (a -> LneM a) -> LneM a
874 fixLne expr env lvs_cont
877 result = expr result env lvs_cont
880 Functions specific to this monad:
883 getVarsLiveInCont :: LneM LiveInfo
884 getVarsLiveInCont env lvs_cont = lvs_cont
886 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
887 setVarsLiveInCont new_lvs_cont expr env lvs_cont
888 = expr env new_lvs_cont
890 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
891 extendVarEnvLne ids_w_howbound expr env lvs_cont
892 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
894 lookupVarLne :: Id -> LneM HowBound
895 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
897 lookupBinding :: IdEnv HowBound -> Id -> HowBound
898 lookupBinding env v = case lookupVarEnv env v of
900 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
903 -- The result of lookupLiveVarsForSet, a set of live variables, is
904 -- only ever tacked onto a decorated expression. It is never used as
905 -- the basis of a control decision, which might give a black hole.
907 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
908 freeVarsToLiveVars fvs env live_in_cont
909 = returnLne live_info env live_in_cont
911 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
912 lvs_from_fvs = map do_one (allFreeIds fvs)
914 do_one (v, how_bound)
916 ImportBound -> unitLiveCaf v -- Only CAF imports are
918 LetBound (TopLet caf_info) _
919 | mayHaveCafRefs caf_info -> unitLiveCaf v
920 | otherwise -> emptyLiveInfo
922 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
923 -- (see the invariant on NestedLet)
925 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
928 %************************************************************************
930 \subsection[Free-var info]{Free variable information}
932 %************************************************************************
935 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
936 -- The Var is so we can gather up the free variables
939 -- The HowBound info just saves repeated lookups;
940 -- we look up just once when we encounter the occurrence.
941 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
942 -- Imported Ids without CAF refs are simply
943 -- not put in the FreeVarsInfo for an expression;
944 -- see singletonFVInfo
947 -- If f is mapped to noBinderInfo, that means
948 -- that f *is* mentioned (else it wouldn't be in the
949 -- IdEnv at all), but perhaps in an unsaturated applications.
951 -- All case/lambda-bound things are also mapped to
952 -- noBinderInfo, since we aren't interested in their
955 -- For ILX we track free var info for type variables too;
956 -- hence VarEnv not IdEnv
960 emptyFVInfo :: FreeVarsInfo
961 emptyFVInfo = emptyVarEnv
963 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
964 -- Don't record non-CAF imports at all, to keep free-var sets small
965 singletonFVInfo id ImportBound info
966 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
967 | otherwise = emptyVarEnv
968 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
970 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
971 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
973 add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
974 -- Type variables must be lambda-bound
976 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
977 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
979 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
980 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
982 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
983 minusFVBinders vs fv = foldr minusFVBinder fv vs
985 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
986 minusFVBinder v fv | isId v && opt_RuntimeTypes
987 = (fv `delVarEnv` v) `unionFVInfo`
988 tyvarFVInfo (tyVarsOfType (idType v))
989 | otherwise = fv `delVarEnv` v
990 -- When removing a binder, remember to add its type variables
991 -- c.f. CoreFVs.delBinderFV
993 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
994 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
996 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
997 -- Find how the given Id is used.
998 -- Externally visible things may be used any old how
1000 | isExternallyVisibleName (idName id) = noBinderInfo
1001 | otherwise = case lookupVarEnv fvs id of
1002 Nothing -> noBinderInfo
1003 Just (_,_,info) -> info
1005 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1006 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1008 -- Non-top-level things only, both type variables and ids
1009 -- (type variables only if opt_RuntimeTypes)
1010 getFVs :: FreeVarsInfo -> [Var]
1011 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1012 not (topLevelBound how_bound) ]
1014 getFVSet :: FreeVarsInfo -> VarSet
1015 getFVSet fvs = mkVarSet (getFVs fvs)
1017 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1018 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1019 (id1, hb1, combineStgBinderInfo info1 info2)
1022 -- The HowBound info for a variable in the FVInfo should be consistent
1023 check_eq_how_bound ImportBound ImportBound = True
1024 check_eq_how_bound LambdaBound LambdaBound = True
1025 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1026 check_eq_how_bound hb1 hb2 = False
1028 check_eq_li (NestedLet _) (NestedLet _) = True
1029 check_eq_li (TopLet _) (TopLet _) = True
1030 check_eq_li li1 li2 = False
1036 filterStgBinders :: [Var] -> [Var]
1037 filterStgBinders bndrs
1038 | opt_RuntimeTypes = bndrs
1039 | otherwise = filter isId bndrs
1044 -- Ignore all notes except SCC
1045 myCollectBinders expr
1048 go bs (Lam b e) = go (b:bs) e
1049 go bs e@(Note (SCC _) _) = (reverse bs, e)
1050 go bs (Note _ e) = go bs e
1051 go bs e = (reverse bs, e)
1053 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1054 -- We assume that we only have variables
1055 -- in the function position by now
1059 go (Var v) as = (v, as)
1060 go (App f a) as = go f (a:as)
1061 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1062 go (Note n e) as = go e as
1063 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1066 %************************************************************************
1068 \subsection{Figuring out CafInfo for an expression}
1070 %************************************************************************
1072 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1073 We mark such things as `MayHaveCafRefs' because this information is
1074 used to decide whether a particular closure needs to be referenced
1077 There are two reasons for setting MayHaveCafRefs:
1078 a) The RHS is a CAF: a top-level updatable thunk.
1079 b) The RHS refers to something that MayHaveCafRefs
1081 Possible improvement: In an effort to keep the number of CAFs (and
1082 hence the size of the SRTs) down, we could also look at the expression and
1083 decide whether it requires a small bounded amount of heap, so we can ignore
1084 it as a CAF. In these cases however, we would need to use an additional
1085 CAF list to keep track of non-collectable CAFs.
1088 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1089 -- Only called for the RHS of top-level lets
1090 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1091 -- predicate returns True for a given Id if we look at this Id when
1092 -- calculating the result. Used to *avoid* looking at the CafInfo
1093 -- field for an Id that is part of the current recursive group.
1096 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1097 | otherwise = NoCafRefs
1099 -- used for recursive groups. The whole group is set to
1100 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1101 -- refers to any CAFs.
1103 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1104 | otherwise = NoCafRefs
1106 -- The environment that cafRefs uses has top-level bindings *only*.
1107 -- We don't bother to add local bindings as cafRefs traverses the expression
1108 -- because they will all be for LocalIds (all nested things are LocalIds)
1109 -- However, we must look in the env first, because some top level things
1110 -- might be local Ids
1113 = case lookupVarEnv p id of
1114 Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info)
1115 Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
1116 | otherwise -> fastBool False -- Nested binder
1117 _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
1119 cafRefs p (Lit l) = fastBool False
1120 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1121 cafRefs p (Lam x e) = cafRefs p e
1122 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1123 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
1124 cafRefs p (Note n e) = cafRefs p e
1125 cafRefs p (Type t) = fastBool False
1127 cafRefss p [] = fastBool False
1128 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1130 -- hack for lazy-or over FastBool.
1131 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1133 isCAF :: CoreExpr -> Bool
1134 -- Only called for the RHS of top-level lets
1135 isCAF e = not (rhsIsNonUpd e)
1136 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1139 rhsIsNonUpd :: CoreExpr -> Bool
1140 -- True => Value-lambda, constructor, PAP
1141 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1142 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1144 -- b) (C x xs), where C is a contructors is updatable if the application is
1145 -- dynamic: see isDynConApp
1147 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1149 -- This function has to line up with what the update flag
1150 -- for the StgRhs gets set to in mkStgRhs (above)
1152 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1153 -- them as making the RHS re-entrant (non-updatable).
1154 rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
1155 rhsIsNonUpd (Note (SCC _) e) = False
1156 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1157 rhsIsNonUpd other_expr
1158 = go other_expr 0 []
1160 go (Var f) n_args args = idAppIsNonUpd f n_args args
1162 go (App f a) n_args args
1163 | isTypeArg a = go f n_args args
1164 | otherwise = go f (n_args + 1) (a:args)
1166 go (Note (SCC _) f) n_args args = False
1167 go (Note _ f) n_args args = go f n_args args
1169 go other n_args args = False
1171 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1172 idAppIsNonUpd id n_val_args args
1173 | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
1174 | otherwise = n_val_args < idArity id
1176 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1177 isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
1178 -- Top-level constructor applications can usually be allocated
1179 -- statically, but they can't if
1180 -- a) the constructor, or any of the arguments, come from another DLL
1181 -- b) any of the arguments are LitLits
1182 -- (because we can't refer to static labels in other DLLs).
1183 -- If this happens we simply make the RHS into an updatable thunk,
1184 -- and 'exectute' it rather than allocating it statically.
1185 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1188 isCrossDllArg :: CoreExpr -> Bool
1189 -- True if somewhere in the expression there's a cross-DLL reference
1190 isCrossDllArg (Type _) = False
1191 isCrossDllArg (Var v) = isDllName (idName v)
1192 isCrossDllArg (Note _ e) = isCrossDllArg e
1193 isCrossDllArg (Lit lit) = isLitLitLit lit
1194 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
1195 isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam