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
504 ImportBound -> idArity f
506 saturated = f_arity <= n_val_args
509 | not_letrec_bound = noBinderInfo -- Uninteresting variable
510 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
511 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
514 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
515 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
516 -- saturated call doesn't escape
517 -- (let-no-escape applies to 'thunks' too)
519 | otherwise = unitVarSet f -- Inexact application; it does escape
521 -- At the moment of the call:
523 -- either the function is *not* let-no-escaped, in which case
524 -- nothing is live except live_in_cont
525 -- or the function *is* let-no-escaped in which case the
526 -- variables it uses are live, but still the function
527 -- itself is not. PS. In this case, the function's
528 -- live vars should already include those of the
529 -- continuation, but it does no harm to just union the
532 res_ty = exprType (mkApps (Var f) args)
533 app = case globalIdDetails f of
534 DataConId dc | saturated -> StgConApp dc args'
535 PrimOpId op -> ASSERT( saturated )
536 StgOpApp (StgPrimOp op) args' res_ty
537 FCallId call -> ASSERT( saturated )
538 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
539 _other -> StgApp f args'
544 fun_fvs `unionFVInfo` args_fvs,
545 fun_escs `unionVarSet` (getFVSet args_fvs)
546 -- All the free vars of the args are disqualified
547 -- from being let-no-escaped.
552 -- ---------------------------------------------------------------------------
554 -- This is the guy that turns applications into A-normal form
555 -- ---------------------------------------------------------------------------
557 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
559 = returnLne ([], emptyFVInfo)
561 coreToStgArgs (Type ty : args) -- Type argument
562 = coreToStgArgs args `thenLne` \ (args', fvs) ->
563 if opt_RuntimeTypes then
564 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
566 returnLne (args', fvs)
568 coreToStgArgs (arg : args) -- Non-type argument
569 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
570 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
572 fvs = args_fvs `unionFVInfo` arg_fvs
573 stg_arg = case arg' of
574 StgApp v [] -> StgVarArg v
575 StgConApp con [] -> StgVarArg (dataConWrapId con)
576 StgLit lit -> StgLitArg lit
577 _ -> pprPanic "coreToStgArgs" (ppr arg)
579 returnLne (stg_arg : stg_args, fvs)
582 -- ---------------------------------------------------------------------------
583 -- The magic for lets:
584 -- ---------------------------------------------------------------------------
587 :: Bool -- True <=> yes, we are let-no-escaping this let
588 -> CoreBind -- bindings
590 -> LneM (StgExpr, -- new let
591 FreeVarsInfo, -- variables free in the whole let
592 EscVarsSet, -- variables that escape from the whole let
593 Bool) -- True <=> none of the binders in the bindings
594 -- is among the escaping vars
596 coreToStgLet let_no_escape bind body
597 = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
599 -- Do the bindings, setting live_in_cont to empty if
600 -- we ain't in a let-no-escape world
601 getVarsLiveInCont `thenLne` \ live_in_cont ->
602 setVarsLiveInCont (if let_no_escape
605 (vars_bind rec_body_fvs bind)
606 `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
609 extendVarEnvLne env_ext (
610 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
611 freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
613 returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
614 body2, body_fvs, body_escs, getLiveVars body_lv_info)
617 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
618 body2, body_fvs, body_escs, body_lvs) ->
621 -- Compute the new let-expression
623 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
624 | otherwise = StgLet bind2 body2
627 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
630 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
632 real_bind_escs = if let_no_escape then
636 -- Everything escapes which is free in the bindings
638 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
640 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
643 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
646 -- Debugging code as requested by Andrew Kennedy
647 checked_no_binder_escapes
648 | not no_binder_escapes && any is_join_var binders
649 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
651 | otherwise = no_binder_escapes
653 checked_no_binder_escapes = no_binder_escapes
656 -- Mustn't depend on the passed-in let_no_escape flag, since
657 -- no_binder_escapes is used by the caller to derive the flag!
663 checked_no_binder_escapes
666 set_of_binders = mkVarSet binders
667 binders = bindersOf bind
669 mk_binding bind_lv_info binder rhs
670 = (binder, LetBound (NestedLet live_vars) (predictArity rhs))
672 live_vars | let_no_escape = addLiveVar bind_lv_info binder
673 | otherwise = unitLiveVar binder
674 -- c.f. the invariant on NestedLet
676 vars_bind :: FreeVarsInfo -- Free var info for body of binding
680 EscVarsSet, -- free vars; escapee vars
681 LiveInfo, -- Vars and CAFs live in binding
682 [(Id, HowBound)]) -- extension to environment
685 vars_bind body_fvs (NonRec binder rhs)
686 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
687 `thenLne` \ (rhs2, bind_fvs, escs) ->
689 freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info ->
691 env_ext_item = mk_binding bind_lv_info binder rhs
693 returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2,
694 bind_fvs, escs, bind_lv_info, [env_ext_item])
697 vars_bind body_fvs (Rec pairs)
698 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
700 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
701 binders = map fst pairs
702 env_ext = [ mk_binding bind_lv_info b rhs
705 extendVarEnvLne env_ext (
706 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
707 `thenLne` \ (rhss2, fvss, escss) ->
709 bind_fvs = unionFVInfos fvss
710 escs = unionVarSets escss
712 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
713 `thenLne` \ bind_lv_info ->
715 returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2),
716 bind_fvs, escs, bind_lv_info, env_ext)
720 is_join_var :: Id -> Bool
721 -- A hack (used only for compiler debuggging) to tell if
722 -- a variable started life as a join point ($j)
723 is_join_var j = occNameUserString (getOccName j) == "$j"
726 %************************************************************************
728 \subsection{Arity prediction}
730 %************************************************************************
732 To avoid yet another knot, we predict the arity of each function from
733 its Core form, based on the number of visible top-level lambdas.
734 It should be the same as the arity of the STG RHS!
737 predictArity :: CoreExpr -> Int
738 predictArity (Lam x e)
739 | isTyVar x = predictArity e
740 | otherwise = 1 + predictArity e
741 predictArity (Note _ e)
742 -- Ignore coercions. Top level sccs are removed by the final
743 -- profiling pass, so we ignore those too.
749 %************************************************************************
751 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
753 %************************************************************************
755 There's a lot of stuff to pass around, so we use this @LneM@ monad to
756 help. All the stuff here is only passed *down*.
759 type LneM a = IdEnv HowBound
760 -> LiveInfo -- Vars and CAFs live in continuation
763 type LiveInfo = (StgLiveVars, -- Dynamic live variables;
764 -- i.e. ones with a nested (non-top-level) binding
765 CafSet) -- Static live variables;
766 -- i.e. top-level variables that are CAFs or refer to them
768 type EscVarsSet = IdSet
772 = ImportBound -- Used only as a response to lookupBinding; never
773 -- exists in the range of the (IdEnv HowBound)
775 | LetBound -- A let(rec) in this module
776 LetInfo -- Whether top level or nested
777 Arity -- Its arity (local Ids don't have arity info at this point)
779 | LambdaBound -- Used for both lambda and case
781 data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live?
782 -- Invariant: the binder itself is always a member of
783 -- the dynamic set of its own LiveInfo
784 | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one?
786 isLetBound (LetBound _ _) = True
787 isLetBound other = False
789 topLevelBound ImportBound = True
790 topLevelBound (LetBound (TopLet _) _) = True
791 topLevelBound other = False
794 For a let(rec)-bound variable, x, we record LiveInfo, the set of
795 variables that are live if x is live. This LiveInfo comprises
796 (a) dynamic live variables (ones with a non-top-level binding)
797 (b) static live variabes (CAFs or things that refer to CAFs)
799 For "normal" variables (a) is just x alone. If x is a let-no-escaped
800 variable then x is represented by a code pointer and a stack pointer
801 (well, one for each stack). So all of the variables needed in the
802 execution of x are live if x is, and are therefore recorded in the
803 LetBound constructor; x itself *is* included.
805 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
809 emptyLiveInfo :: LiveInfo
810 emptyLiveInfo = (emptyVarSet,emptyVarSet)
812 unitLiveVar :: Id -> LiveInfo
813 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
815 unitLiveCaf :: Id -> LiveInfo
816 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
818 addLiveVar :: LiveInfo -> Id -> LiveInfo
819 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
821 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
822 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
824 mkSRT :: LiveInfo -> SRT
825 mkSRT (_, cafs) = SRTEntries cafs
827 getLiveVars :: LiveInfo -> StgLiveVars
828 getLiveVars (lvs, _) = lvs
832 The std monad functions:
834 initLne :: IdEnv HowBound -> LneM a -> a
835 initLne env m = m env emptyLiveInfo
839 {-# INLINE thenLne #-}
840 {-# INLINE returnLne #-}
842 returnLne :: a -> LneM a
843 returnLne e env lvs_cont = e
845 thenLne :: LneM a -> (a -> LneM b) -> LneM b
846 thenLne m k env lvs_cont
847 = k (m env lvs_cont) env lvs_cont
849 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
850 mapLne f [] = returnLne []
852 = f x `thenLne` \ r ->
853 mapLne f xs `thenLne` \ rs ->
856 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
858 mapAndUnzipLne f [] = returnLne ([],[])
859 mapAndUnzipLne f (x:xs)
860 = f x `thenLne` \ (r1, r2) ->
861 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
862 returnLne (r1:rs1, r2:rs2)
864 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
866 mapAndUnzip3Lne f [] = returnLne ([],[],[])
867 mapAndUnzip3Lne f (x:xs)
868 = f x `thenLne` \ (r1, r2, r3) ->
869 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
870 returnLne (r1:rs1, r2:rs2, r3:rs3)
872 fixLne :: (a -> LneM a) -> LneM a
873 fixLne expr env lvs_cont
876 result = expr result env lvs_cont
879 Functions specific to this monad:
882 getVarsLiveInCont :: LneM LiveInfo
883 getVarsLiveInCont env lvs_cont = lvs_cont
885 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
886 setVarsLiveInCont new_lvs_cont expr env lvs_cont
887 = expr env new_lvs_cont
889 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
890 extendVarEnvLne ids_w_howbound expr env lvs_cont
891 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
893 lookupVarLne :: Id -> LneM HowBound
894 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
896 lookupBinding :: IdEnv HowBound -> Id -> HowBound
897 lookupBinding env v = case lookupVarEnv env v of
899 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
902 -- The result of lookupLiveVarsForSet, a set of live variables, is
903 -- only ever tacked onto a decorated expression. It is never used as
904 -- the basis of a control decision, which might give a black hole.
906 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
907 freeVarsToLiveVars fvs env live_in_cont
908 = returnLne live_info env live_in_cont
910 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
911 lvs_from_fvs = map do_one (allFreeIds fvs)
913 do_one (v, how_bound)
915 ImportBound -> unitLiveCaf v -- Only CAF imports are
917 LetBound (TopLet caf_info) _
918 | mayHaveCafRefs caf_info -> unitLiveCaf v
919 | otherwise -> emptyLiveInfo
921 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
922 -- (see the invariant on NestedLet)
924 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
927 %************************************************************************
929 \subsection[Free-var info]{Free variable information}
931 %************************************************************************
934 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
935 -- The Var is so we can gather up the free variables
938 -- The HowBound info just saves repeated lookups;
939 -- we look up just once when we encounter the occurrence.
940 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
941 -- Imported Ids without CAF refs are simply
942 -- not put in the FreeVarsInfo for an expression.
943 -- See singletonFVInfo and freeVarsToLiveVars
945 -- StgBinderInfo records how it occurs; notably, we
946 -- are interested in whether it only occurs in saturated
947 -- applications, because then we don't need to build a
949 -- If f is mapped to noBinderInfo, that means
950 -- that f *is* mentioned (else it wouldn't be in the
951 -- IdEnv at all), but perhaps in an unsaturated applications.
953 -- All case/lambda-bound things are also mapped to
954 -- noBinderInfo, since we aren't interested in their
957 -- For ILX we track free var info for type variables too;
958 -- hence VarEnv not IdEnv
962 emptyFVInfo :: FreeVarsInfo
963 emptyFVInfo = emptyVarEnv
965 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
966 -- Don't record non-CAF imports at all, to keep free-var sets small
967 singletonFVInfo id ImportBound info
968 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
969 | otherwise = emptyVarEnv
970 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
972 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
973 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
975 add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
976 -- Type variables must be lambda-bound
978 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
979 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
981 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
982 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
984 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
985 minusFVBinders vs fv = foldr minusFVBinder fv vs
987 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
988 minusFVBinder v fv | isId v && opt_RuntimeTypes
989 = (fv `delVarEnv` v) `unionFVInfo`
990 tyvarFVInfo (tyVarsOfType (idType v))
991 | otherwise = fv `delVarEnv` v
992 -- When removing a binder, remember to add its type variables
993 -- c.f. CoreFVs.delBinderFV
995 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
996 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
998 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
999 -- Find how the given Id is used.
1000 -- Externally visible things may be used any old how
1002 | isExternallyVisibleName (idName id) = noBinderInfo
1003 | otherwise = case lookupVarEnv fvs id of
1004 Nothing -> noBinderInfo
1005 Just (_,_,info) -> info
1007 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1008 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id]
1010 -- Non-top-level things only, both type variables and ids
1011 -- (type variables only if opt_RuntimeTypes)
1012 getFVs :: FreeVarsInfo -> [Var]
1013 getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs,
1014 not (topLevelBound how_bound) ]
1016 getFVSet :: FreeVarsInfo -> VarSet
1017 getFVSet fvs = mkVarSet (getFVs fvs)
1019 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1020 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1021 (id1, hb1, combineStgBinderInfo info1 info2)
1024 -- The HowBound info for a variable in the FVInfo should be consistent
1025 check_eq_how_bound ImportBound ImportBound = True
1026 check_eq_how_bound LambdaBound LambdaBound = True
1027 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1028 check_eq_how_bound hb1 hb2 = False
1030 check_eq_li (NestedLet _) (NestedLet _) = True
1031 check_eq_li (TopLet _) (TopLet _) = True
1032 check_eq_li li1 li2 = False
1038 filterStgBinders :: [Var] -> [Var]
1039 filterStgBinders bndrs
1040 | opt_RuntimeTypes = bndrs
1041 | otherwise = filter isId bndrs
1046 -- Ignore all notes except SCC
1047 myCollectBinders expr
1050 go bs (Lam b e) = go (b:bs) e
1051 go bs e@(Note (SCC _) _) = (reverse bs, e)
1052 go bs (Note _ e) = go bs e
1053 go bs e = (reverse bs, e)
1055 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1056 -- We assume that we only have variables
1057 -- in the function position by now
1061 go (Var v) as = (v, as)
1062 go (App f a) as = go f (a:as)
1063 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1064 go (Note n e) as = go e as
1065 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1068 %************************************************************************
1070 \subsection{Figuring out CafInfo for an expression}
1072 %************************************************************************
1074 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1075 We mark such things as `MayHaveCafRefs' because this information is
1076 used to decide whether a particular closure needs to be referenced
1079 There are two reasons for setting MayHaveCafRefs:
1080 a) The RHS is a CAF: a top-level updatable thunk.
1081 b) The RHS refers to something that MayHaveCafRefs
1083 Possible improvement: In an effort to keep the number of CAFs (and
1084 hence the size of the SRTs) down, we could also look at the expression and
1085 decide whether it requires a small bounded amount of heap, so we can ignore
1086 it as a CAF. In these cases however, we would need to use an additional
1087 CAF list to keep track of non-collectable CAFs.
1090 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1091 -- Only called for the RHS of top-level lets
1092 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1093 -- predicate returns True for a given Id if we look at this Id when
1094 -- calculating the result. Used to *avoid* looking at the CafInfo
1095 -- field for an Id that is part of the current recursive group.
1098 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1099 | otherwise = NoCafRefs
1101 -- used for recursive groups. The whole group is set to
1102 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1103 -- refers to any CAFs.
1105 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1106 | otherwise = NoCafRefs
1108 -- The environment that cafRefs uses has top-level bindings *only*.
1109 -- We don't bother to add local bindings as cafRefs traverses the expression
1110 -- because they will all be for LocalIds (all nested things are LocalIds)
1111 -- However, we must look in the env first, because some top level things
1112 -- might be local Ids
1115 = case lookupVarEnv p id of
1116 Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info)
1117 Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
1118 | otherwise -> fastBool False -- Nested binder
1119 _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
1121 cafRefs p (Lit l) = fastBool False
1122 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1123 cafRefs p (Lam x e) = cafRefs p e
1124 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1125 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
1126 cafRefs p (Note n e) = cafRefs p e
1127 cafRefs p (Type t) = fastBool False
1129 cafRefss p [] = fastBool False
1130 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1132 -- hack for lazy-or over FastBool.
1133 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1135 isCAF :: CoreExpr -> Bool
1136 -- Only called for the RHS of top-level lets
1137 isCAF e = not (rhsIsNonUpd e)
1138 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1141 rhsIsNonUpd :: CoreExpr -> Bool
1142 -- True => Value-lambda, constructor, PAP
1143 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1144 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1146 -- b) (C x xs), where C is a contructors is updatable if the application is
1147 -- dynamic: see isDynConApp
1149 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1151 -- This function has to line up with what the update flag
1152 -- for the StgRhs gets set to in mkStgRhs (above)
1154 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1155 -- them as making the RHS re-entrant (non-updatable).
1156 rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
1157 rhsIsNonUpd (Note (SCC _) e) = False
1158 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1159 rhsIsNonUpd other_expr
1160 = go other_expr 0 []
1162 go (Var f) n_args args = idAppIsNonUpd f n_args args
1164 go (App f a) n_args args
1165 | isTypeArg a = go f n_args args
1166 | otherwise = go f (n_args + 1) (a:args)
1168 go (Note (SCC _) f) n_args args = False
1169 go (Note _ f) n_args args = go f n_args args
1171 go other n_args args = False
1173 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1174 idAppIsNonUpd id n_val_args args
1175 | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
1176 | otherwise = n_val_args < idArity id
1178 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1179 isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
1180 -- Top-level constructor applications can usually be allocated
1181 -- statically, but they can't if
1182 -- a) the constructor, or any of the arguments, come from another DLL
1183 -- b) any of the arguments are LitLits
1184 -- (because we can't refer to static labels in other DLLs).
1185 -- If this happens we simply make the RHS into an updatable thunk,
1186 -- and 'exectute' it rather than allocating it statically.
1187 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1190 isCrossDllArg :: CoreExpr -> Bool
1191 -- True if somewhere in the expression there's a cross-DLL reference
1192 isCrossDllArg (Type _) = False
1193 isCrossDllArg (Var v) = isDllName (idName v)
1194 isCrossDllArg (Note _ e) = isCrossDllArg e
1195 isCrossDllArg (Lit lit) = isLitLitLit lit
1196 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
1197 isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam