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 )
38 import List ( partition )
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)
119 %************************************************************************
121 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
123 %************************************************************************
126 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
129 where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm
131 coreExprToStg :: CoreExpr -> StgExpr
133 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
137 :: IdEnv HowBound -- environment for the bindings
139 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
141 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
142 coreTopBindsToStg env (b:bs)
143 = (env2, fvs2, b':bs')
145 -- env accumulates down the list of binds, fvs accumulates upwards
146 (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
147 (env2, fvs1, bs') = coreTopBindsToStg env1 bs
152 -> FreeVarsInfo -- Info about the body
154 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
156 coreTopBindToStg env body_fvs (NonRec id rhs)
158 caf_info = hasCafRefs env rhs
160 env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
162 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
163 | otherwise = TopLevelNoCafs
165 (stg_rhs, fvs', cafs) =
167 coreToStgRhs body_fvs TopLevel (id,rhs)
168 `thenLne` \ (stg_rhs, fvs', _) ->
169 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
170 returnLne (stg_rhs, fvs', cafs)
173 bind = StgNonRec (SRTEntries cafs) id stg_rhs
175 ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
176 ASSERT2(consistent caf_info bind, ppr id)
177 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
178 (env', fvs' `unionFVInfo` body_fvs, bind)
180 coreTopBindToStg env body_fvs (Rec pairs)
182 (binders, rhss) = unzip pairs
184 -- to calculate caf_info, we initially map all the binders to
186 env1 = extendVarEnvList env
187 [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
190 caf_info = hasCafRefss env1{-NB: not env'-} rhss
192 env' = extendVarEnvList env
193 [ (b, LetBound how_bound emptyLVS (predictArity rhs))
196 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
197 | otherwise = TopLevelNoCafs
199 (stg_rhss, fvs', cafs)
201 mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
202 `thenLne` \ (stg_rhss, fvss', _) ->
203 let fvs' = unionFVInfos fvss' in
204 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
205 returnLne (stg_rhss, fvs', cafs)
208 bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
210 ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
211 ASSERT2(consistent caf_info bind, ppr binders)
212 -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
213 (env', fvs' `unionFVInfo` body_fvs, bind)
216 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
221 :: FreeVarsInfo -- Free var info for the scope of the binding
224 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
226 coreToStgRhs scope_fv_info top (binder, rhs)
227 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
228 returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
231 binder_info = lookupFVInfo scope_fv_info binder
233 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
236 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
237 = StgRhsClosure noCCS binder_info
242 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
243 | isNotTopLevel top || not (isDllConApp con args)
244 = StgRhsCon noCCS con args
246 mkStgRhs top rhs_fvs binder_info rhs
247 = StgRhsClosure noCCS binder_info
252 updatable args body | null args && isPAP body = ReEntrant
253 | otherwise = Updatable
255 upd = if isOnceDem dem
256 then (if isNotTop toplev
257 then SingleEntry -- HA! Paydirt for "dem"
260 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
264 -- For now we forbid SingleEntry CAFs; they tickle the
265 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
266 -- and I don't understand why. There's only one SE_CAF (well,
267 -- only one that tickled a great gaping bug in an earlier attempt
268 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
269 -- specifically Main.lvl6 in spectral/cryptarithm2.
270 -- So no great loss. KSW 2000-07.
274 Detect thunks which will reduce immediately to PAPs, and make them
275 non-updatable. This has several advantages:
277 - the non-updatable thunk behaves exactly like the PAP,
279 - the thunk is more efficient to enter, because it is
280 specialised to the task.
282 - we save one update frame, one stg_update_PAP, one update
283 and lots of PAP_enters.
285 - in the case where the thunk is top-level, we save building
286 a black hole and futhermore the thunk isn't considered to
287 be a CAF any more, so it doesn't appear in any SRTs.
289 We do it here, because the arity information is accurate, and we need
290 to do it before the SRT pass to save the SRT entries associated with
294 isPAP (StgApp f args) = idArity f > length args
299 -- ---------------------------------------------------------------------------
301 -- ---------------------------------------------------------------------------
306 -> LneM (StgExpr, -- Decorated STG expr
307 FreeVarsInfo, -- Its free vars (NB free, not live)
308 EscVarsSet) -- Its escapees, a subset of its free vars;
309 -- also a subset of the domain of the envt
310 -- because we are only interested in the escapees
311 -- for vars which might be turned into
312 -- let-no-escaped ones.
315 The second and third components can be derived in a simple bottom up pass, not
316 dependent on any decisions about which variables will be let-no-escaped or
317 not. The first component, that is, the decorated expression, may then depend
318 on these components, but it in turn is not scrutinised as the basis for any
319 decisions. Hence no black holes.
322 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
323 coreToStgExpr (Var v) = coreToStgApp Nothing v []
325 coreToStgExpr expr@(App _ _)
326 = coreToStgApp Nothing f args
328 (f, args) = myCollectArgs expr
330 coreToStgExpr expr@(Lam _ _)
331 = let (args, body) = myCollectBinders expr
332 args' = filterStgBinders args
334 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
335 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
337 set_of_args = mkVarSet args'
338 fvs = args' `minusFVBinders` body_fvs
339 escs = body_escs `minusVarSet` set_of_args
340 result_expr | null args' = body
341 | otherwise = StgLam (exprType expr) args' body
343 returnLne (result_expr, fvs, escs)
345 coreToStgExpr (Note (SCC cc) expr)
346 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
347 returnLne (StgSCC cc expr2, fvs, escs) )
349 coreToStgExpr (Note other_note expr)
353 -- Cases require a little more real work.
355 coreToStgExpr (Case scrut bndr alts)
356 = extendVarEnvLne [(bndr, CaseBound)] $
357 vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
358 freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
360 -- determine whether the default binder is dead or not
361 -- This helps the code generator to avoid generating an assignment
362 -- for the case binder (is extremely rare cases) ToDo: remove.
363 bndr'= if (bndr `elementOfFVInfo` alts_fvs)
365 else bndr `setIdOccInfo` IAmDead
367 -- Don't consider the default binder as being 'live in alts',
368 -- since this is from the point of view of the case expr, where
369 -- the default binder is not free.
370 live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
372 -- we tell the scrutinee that everything live in the alts
373 -- is live in it, too.
374 setVarsLiveInCont (live_in_alts,alts_caf_refs) (
375 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
376 freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
377 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
379 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
381 let srt = SRTEntries alts_caf_refs
384 StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
385 bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
386 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
387 -- You might think we should have scrut_escs, not
388 -- (getFVSet scrut_fvs), but actually we can't call, and
389 -- then return from, a let-no-escape thing.
392 scrut_ty = idType bndr
393 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
395 vars_alts (alts,deflt)
397 = mapAndUnzip3Lne vars_prim_alt alts
398 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
400 alts_fvs = unionFVInfos alts_fvs_list
401 alts_escs = unionVarSets alts_escs_list
403 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
405 mkStgPrimAlts scrut_ty alts2 deflt2,
406 alts_fvs `unionFVInfo` deflt_fvs,
407 alts_escs `unionVarSet` deflt_escs
411 = mapAndUnzip3Lne vars_alg_alt alts
412 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
414 alts_fvs = unionFVInfos alts_fvs_list
415 alts_escs = unionVarSets alts_escs_list
417 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
419 mkStgAlgAlts scrut_ty alts2 deflt2,
420 alts_fvs `unionFVInfo` deflt_fvs,
421 alts_escs `unionVarSet` deflt_escs
425 vars_prim_alt (LitAlt lit, _, rhs)
426 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
427 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
429 vars_alg_alt (DataAlt con, binders, rhs)
431 -- remove type variables
432 binders' = filterStgBinders binders
434 extendVarEnvLne [(b, CaseBound) | b <- binders'] $
435 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
437 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
438 -- records whether each param is used in the RHS
441 (con, binders', good_use_mask, rhs2),
442 binders' `minusFVBinders` rhs_fvs,
443 rhs_escs `minusVarSet` mkVarSet binders'
444 -- ToDo: remove the minusVarSet;
445 -- since escs won't include any of these binders
447 vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
450 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
452 vars_deflt (Just rhs)
453 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
454 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
457 Lets not only take quite a bit of work, but this is where we convert
458 then to let-no-escapes, if we wish.
460 (Meanwhile, we don't expect to see let-no-escapes...)
462 coreToStgExpr (Let bind body)
463 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
464 coreToStgLet no_binder_escapes bind body
465 ) `thenLne` \ (new_let, fvs, escs, _) ->
467 returnLne (new_let, fvs, escs)
471 mkStgAlgAlts ty alts deflt
473 -- Get the tycon from the data con
474 (dc, _, _, _) : _rest
475 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
477 -- Otherwise just do your best
478 [] -> case splitTyConApp_maybe (repType ty) of
479 Just (tc,_) | isAlgTyCon tc
480 -> StgAlgAlts (Just tc) alts deflt
482 -> StgAlgAlts Nothing alts deflt
484 mkStgPrimAlts ty alts deflt
485 = StgPrimAlts (tyConAppTyCon ty) alts deflt
489 -- ---------------------------------------------------------------------------
491 -- ---------------------------------------------------------------------------
495 :: Maybe UpdateFlag -- Just upd <=> this application is
496 -- the rhs of a thunk binding
497 -- x = [...] \upd [] -> the_app
498 -- with specified update flag
500 -> [CoreArg] -- Arguments
501 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
503 coreToStgApp maybe_thunk_body f args
504 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
505 lookupVarLne f `thenLne` \ how_bound ->
508 n_val_args = valArgCount args
509 not_letrec_bound = not (isLetBound how_bound)
511 = let fvs = singletonFVInfo f how_bound fun_occ in
512 -- e.g. (f :: a -> int) (x :: a)
513 -- Here the free variables are "f", "x" AND the type variable "a"
514 -- coreToStgArgs will deal with the arguments recursively
515 if opt_RuntimeTypes then
516 fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f))
519 -- Mostly, the arity info of a function is in the fn's IdInfo
520 -- But new bindings introduced by CoreSat may not have no
521 -- arity info; it would do us no good anyway. For example:
522 -- let f = \ab -> e in f
523 -- No point in having correct arity info for f!
524 -- Hence the hasArity stuff below.
525 f_arity = case how_bound of
526 LetBound _ _ arity -> arity
530 | not_letrec_bound = noBinderInfo -- Uninteresting variable
531 | f_arity > 0 && f_arity <= n_val_args = stgSatOcc -- Saturated or over-saturated function call
532 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
535 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
536 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
537 -- saturated call doesn't escape
538 -- (let-no-escape applies to 'thunks' too)
540 | otherwise = unitVarSet f -- Inexact application; it does escape
542 -- At the moment of the call:
544 -- either the function is *not* let-no-escaped, in which case
545 -- nothing is live except live_in_cont
546 -- or the function *is* let-no-escaped in which case the
547 -- variables it uses are live, but still the function
548 -- itself is not. PS. In this case, the function's
549 -- live vars should already include those of the
550 -- continuation, but it does no harm to just union the
553 res_ty = exprType (mkApps (Var f) args)
554 app = case globalIdDetails f of
555 DataConId dc -> StgConApp dc args'
556 PrimOpId op -> StgOpApp (StgPrimOp op) args' res_ty
557 FCallId call -> StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
558 _other -> StgApp f args'
563 fun_fvs `unionFVInfo` args_fvs,
564 fun_escs `unionVarSet` (getFVSet args_fvs)
565 -- All the free vars of the args are disqualified
566 -- from being let-no-escaped.
571 -- ---------------------------------------------------------------------------
573 -- This is the guy that turns applications into A-normal form
574 -- ---------------------------------------------------------------------------
576 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
578 = returnLne ([], emptyFVInfo)
580 coreToStgArgs (Type ty : args) -- Type argument
581 = coreToStgArgs args `thenLne` \ (args', fvs) ->
582 if opt_RuntimeTypes then
583 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
585 returnLne (args', fvs)
587 coreToStgArgs (arg : args) -- Non-type argument
588 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
589 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
591 fvs = args_fvs `unionFVInfo` arg_fvs
592 stg_arg = case arg' of
593 StgApp v [] -> StgVarArg v
594 StgConApp con [] -> StgVarArg (dataConWrapId con)
595 StgLit lit -> StgLitArg lit
596 _ -> pprPanic "coreToStgArgs" (ppr arg)
598 returnLne (stg_arg : stg_args, fvs)
601 -- ---------------------------------------------------------------------------
602 -- The magic for lets:
603 -- ---------------------------------------------------------------------------
606 :: Bool -- True <=> yes, we are let-no-escaping this let
607 -> CoreBind -- bindings
609 -> LneM (StgExpr, -- new let
610 FreeVarsInfo, -- variables free in the whole let
611 EscVarsSet, -- variables that escape from the whole let
612 Bool) -- True <=> none of the binders in the bindings
613 -- is among the escaping vars
615 coreToStgLet let_no_escape bind body
616 = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
618 -- Do the bindings, setting live_in_cont to empty if
619 -- we ain't in a let-no-escape world
620 getVarsLiveInCont `thenLne` \ live_in_cont ->
621 setVarsLiveInCont (if let_no_escape
624 (vars_bind rec_body_fvs bind)
625 `thenLne` \ ( bind2, bind_fvs, bind_escs
626 , bind_lvs, bind_cafs, env_ext) ->
629 extendVarEnvLne env_ext (
630 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
631 freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
633 returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
634 body2, body_fvs, body_escs, body_lvs)
637 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
638 body2, body_fvs, body_escs, body_lvs) ->
641 -- Compute the new let-expression
643 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
644 | otherwise = StgLet bind2 body2
647 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
650 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
652 real_bind_escs = if let_no_escape then
656 -- Everything escapes which is free in the bindings
658 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
660 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
663 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
666 -- Debugging code as requested by Andrew Kennedy
667 checked_no_binder_escapes
668 | not no_binder_escapes && any is_join_var binders
669 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
671 | otherwise = no_binder_escapes
673 checked_no_binder_escapes = no_binder_escapes
676 -- Mustn't depend on the passed-in let_no_escape flag, since
677 -- no_binder_escapes is used by the caller to derive the flag!
683 checked_no_binder_escapes
686 set_of_binders = mkVarSet binders
687 binders = case bind of
688 NonRec binder rhs -> [binder]
689 Rec pairs -> map fst pairs
691 mk_binding bind_lvs bind_cafs binder rhs
692 = (binder, LetBound NotTopLevelBound -- Not top level
693 live_vars (predictArity rhs)
696 live_vars = if let_no_escape then
697 (extendVarSet bind_lvs binder, bind_cafs)
699 (unitVarSet binder, emptyVarSet)
701 vars_bind :: FreeVarsInfo -- Free var info for body of binding
705 EscVarsSet, -- free vars; escapee vars
706 StgLiveVars, -- vars live in binding
707 IdSet, -- CAFs live in binding
708 [(Id, HowBound)]) -- extension to environment
711 vars_bind body_fvs (NonRec binder rhs)
712 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
713 `thenLne` \ (rhs2, bind_fvs, escs) ->
715 freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
717 env_ext_item = mk_binding bind_lvs bind_cafs binder rhs
719 returnLne (StgNonRec (SRTEntries bind_cafs) binder rhs2,
720 bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
723 vars_bind body_fvs (Rec pairs)
724 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
726 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
727 binders = map fst pairs
728 env_ext = [ mk_binding bind_lvs bind_cafs b rhs
731 extendVarEnvLne env_ext (
732 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
733 `thenLne` \ (rhss2, fvss, escss) ->
735 bind_fvs = unionFVInfos fvss
736 escs = unionVarSets escss
738 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
739 `thenLne` \ (bind_lvs, bind_cafs) ->
741 returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
742 bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
746 is_join_var :: Id -> Bool
747 -- A hack (used only for compiler debuggging) to tell if
748 -- a variable started life as a join point ($j)
749 is_join_var j = occNameUserString (getOccName j) == "$j"
752 %************************************************************************
754 \subsection{Arity prediction}
756 %************************************************************************
758 To avoid yet another knot, we predict the arity of each function from
759 its Core form, based on the number of visible top-level lambdas.
760 It should be the same as the arity of the STG RHS!
763 predictArity :: CoreExpr -> Int
764 predictArity (Lam x e)
765 | isTyVar x = predictArity e
766 | otherwise = 1 + predictArity e
767 predictArity (Note _ e)
768 -- Ignore coercions. Top level sccs are removed by the final
769 -- profiling pass, so we ignore those too.
775 %************************************************************************
777 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
779 %************************************************************************
781 There's a lot of stuff to pass around, so we use this @LneM@ monad to
782 help. All the stuff here is only passed *down*.
785 type LneM a = IdEnv HowBound
786 -> (StgLiveVars, -- vars live in continuation
787 IdSet) -- cafs live in continuation
791 = ImportBound -- Used only as a response to lookupBinding; never
792 -- exists in the range of the (IdEnv HowBound)
797 (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
798 Arity -- its arity (local Ids don't have arity info at this point)
800 isLetBound (LetBound _ _ _) = True
801 isLetBound other = False
804 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
805 variables that are live if x is live. For "normal" variables that is
806 just x alone. If x is a let-no-escaped variable then x is represented
807 by a code pointer and a stack pointer (well, one for each stack). So
808 all of the variables needed in the execution of x are live if x is,
809 and are therefore recorded in the LetBound constructor; x itself
812 The set of live variables is guaranteed ot have no further let-no-escaped
815 The std monad functions:
817 initLne :: IdEnv HowBound -> LneM a -> a
818 initLne env m = m env emptyLVS
820 emptyLVS = (emptyVarSet,emptyVarSet)
822 {-# INLINE thenLne #-}
823 {-# INLINE returnLne #-}
825 returnLne :: a -> LneM a
826 returnLne e env lvs_cont = e
828 thenLne :: LneM a -> (a -> LneM b) -> LneM b
829 thenLne m k env lvs_cont
830 = k (m env lvs_cont) env lvs_cont
832 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
833 mapLne f [] = returnLne []
835 = f x `thenLne` \ r ->
836 mapLne f xs `thenLne` \ rs ->
839 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
841 mapAndUnzipLne f [] = returnLne ([],[])
842 mapAndUnzipLne f (x:xs)
843 = f x `thenLne` \ (r1, r2) ->
844 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
845 returnLne (r1:rs1, r2:rs2)
847 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
849 mapAndUnzip3Lne f [] = returnLne ([],[],[])
850 mapAndUnzip3Lne f (x:xs)
851 = f x `thenLne` \ (r1, r2, r3) ->
852 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
853 returnLne (r1:rs1, r2:rs2, r3:rs3)
855 fixLne :: (a -> LneM a) -> LneM a
856 fixLne expr env lvs_cont
859 result = expr result env lvs_cont
862 Functions specific to this monad:
865 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
866 getVarsLiveInCont env lvs_cont = lvs_cont
868 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
869 setVarsLiveInCont new_lvs_cont expr env lvs_cont
870 = expr env new_lvs_cont
872 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
873 extendVarEnvLne ids_w_howbound expr env lvs_cont
874 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
876 lookupVarLne :: Id -> LneM HowBound
877 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
879 lookupBinding :: IdEnv HowBound -> Id -> HowBound
880 lookupBinding env v = case lookupVarEnv env v of
882 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
885 -- The result of lookupLiveVarsForSet, a set of live variables, is
886 -- only ever tacked onto a decorated expression. It is never used as
887 -- the basis of a control decision, which might give a black hole.
889 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
890 freeVarsToLiveVars fvs env live_in_cont
891 = returnLne (lvs, cafs) env live_in_cont
893 (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
895 (lvs_from_fvs, caf_from_fvs) = unzip (map do_one (allFreeIds fvs))
897 lvs = unionVarSets lvs_from_fvs `unionVarSet` lvs_cont
898 cafs = unionVarSets caf_from_fvs `unionVarSet` cafs_cont
901 = case lookupBinding env v of
902 LetBound caf_ness (lvs,cafs) _ ->
904 TopLevelHasCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, unitVarSet v)
905 TopLevelNoCafs -> ASSERT( isEmptyVarSet lvs ) (emptyVarSet, emptyVarSet)
906 NotTopLevelBound -> (extendVarSet lvs v, cafs)
908 ImportBound | mayHaveCafRefs (idCafInfo v) -> (emptyVarSet, unitVarSet v)
909 | otherwise -> (emptyVarSet, emptyVarSet)
911 _nested_binding -> (unitVarSet v, emptyVarSet) -- Bound by lambda or case
914 %************************************************************************
916 \subsection[Free-var info]{Free variable information}
918 %************************************************************************
921 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
922 -- If f is mapped to noBinderInfo, that means
923 -- that f *is* mentioned (else it wouldn't be in the
924 -- IdEnv at all), but perhaps in an unsaturated applications.
926 -- All case/lambda-bound things are also mapped to
927 -- noBinderInfo, since we aren't interested in their
930 -- For ILX we track free var info for type variables too;
931 -- hence VarEnv not IdEnv
939 type EscVarsSet = IdSet
943 emptyFVInfo :: FreeVarsInfo
944 emptyFVInfo = emptyVarEnv
946 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
947 singletonFVInfo id ImportBound info
948 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
949 | otherwise = emptyVarEnv
950 singletonFVInfo id (LetBound top_level _ _) info
951 = unitVarEnv id (id, top_level, info)
952 singletonFVInfo id other info
953 = unitVarEnv id (id, NotTopLevelBound, info)
955 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
956 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
958 add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
960 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
961 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
963 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
964 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
966 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
967 minusFVBinders vs fv = foldr minusFVBinder fv vs
969 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
970 minusFVBinder v fv | isId v && opt_RuntimeTypes
971 = (fv `delVarEnv` v) `unionFVInfo`
972 tyvarFVInfo (tyVarsOfType (idType v))
973 | otherwise = fv `delVarEnv` v
974 -- When removing a binder, remember to add its type variables
975 -- c.f. CoreFVs.delBinderFV
977 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
978 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
980 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
981 -- Find how the given Id is used.
982 -- Externally visible things may be used any old how
984 | isExternallyVisibleName (idName id) = noBinderInfo
985 | otherwise = case lookupVarEnv fvs id of
986 Nothing -> noBinderInfo
987 Just (_,_,info) -> info
989 allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only
990 allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id]
992 -- Non-top-level things only, both type variables and ids (type variables
993 -- only if opt_RuntimeTypes.
994 getFVs :: FreeVarsInfo -> [Var]
995 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
997 getFVSet :: FreeVarsInfo -> VarSet
998 getFVSet fvs = mkVarSet (getFVs fvs)
1000 plusFVInfo (id1,top1,info1) (id2,top2,info2)
1001 = ASSERT (id1 == id2 && top1 == top2)
1002 (id1, top1, combineStgBinderInfo info1 info2)
1007 filterStgBinders :: [Var] -> [Var]
1008 filterStgBinders bndrs
1009 | opt_RuntimeTypes = bndrs
1010 | otherwise = filter isId bndrs
1015 -- Ignore all notes except SCC
1016 myCollectBinders expr
1019 go bs (Lam b e) = go (b:bs) e
1020 go bs e@(Note (SCC _) _) = (reverse bs, e)
1021 go bs (Note _ e) = go bs e
1022 go bs e = (reverse bs, e)
1024 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1025 -- We assume that we only have variables
1026 -- in the function position by now
1030 go (Var v) as = (v, as)
1031 go (App f a) as = go f (a:as)
1032 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1033 go (Note n e) as = go e as
1034 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1037 %************************************************************************
1039 \subsection{Figuring out CafInfo for an expression}
1041 %************************************************************************
1043 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1044 We mark such things as `MayHaveCafRefs' because this information is
1045 used to decide whether a particular closure needs to be referenced
1048 There are two reasons for setting MayHaveCafRefs:
1049 a) The RHS is a CAF: a top-level updatable thunk.
1050 b) The RHS refers to something that MayHaveCafRefs
1052 Possible improvement: In an effort to keep the number of CAFs (and
1053 hence the size of the SRTs) down, we could also look at the expression and
1054 decide whether it requires a small bounded amount of heap, so we can ignore
1055 it as a CAF. In these cases however, we would need to use an additional
1056 CAF list to keep track of non-collectable CAFs.
1059 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1060 -- Only called for the RHS of top-level lets
1061 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1062 -- predicate returns True for a given Id if we look at this Id when
1063 -- calculating the result. Used to *avoid* looking at the CafInfo
1064 -- field for an Id that is part of the current recursive group.
1067 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1068 | otherwise = NoCafRefs
1070 -- used for recursive groups. The whole group is set to
1071 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1072 -- refers to any CAFs.
1074 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1075 | otherwise = NoCafRefs
1077 -- The environment that cafRefs uses has top-level bindings *only*.
1078 -- We don't bother to add local bindings as cafRefs traverses the expression
1079 -- because they will all be for LocalIds (all nested things are LocalIds)
1080 -- However, we must look in the env first, because some top level things
1081 -- might be local Ids
1084 = case lookupVarEnv p id of
1085 Just (LetBound TopLevelHasCafs _ _) -> fastBool True -- Top level
1086 Just (LetBound TopLevelNoCafs _ _) -> fastBool False -- Top level
1087 Nothing | isLocalId id -> fastBool False -- Nested binder
1088 | otherwise -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
1089 Just _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
1092 cafRefs p (Lit l) = fastBool False
1093 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1094 cafRefs p (Lam x e) = cafRefs p e
1095 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1096 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1097 (cafRefss p) (rhssOfAlts alts)
1098 cafRefs p (Note n e) = cafRefs p e
1099 cafRefs p (Type t) = fastBool False
1101 cafRefss p [] = fastBool False
1102 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1104 -- hack for lazy-or over FastBool.
1105 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1107 isCAF :: CoreExpr -> Bool
1108 -- Only called for the RHS of top-level lets
1109 isCAF e = not (rhsIsNonUpd e)
1110 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1113 rhsIsNonUpd :: CoreExpr -> Bool
1114 -- True => Value-lambda, constructor, PAP
1115 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1116 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1118 -- b) (C x xs), where C is a contructors is updatable if the application is
1119 -- dynamic: see isDynConApp
1121 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1123 -- This function has to line up with what the update flag
1124 -- for the StgRhs gets set to in mkStgRhs (above)
1126 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1127 -- them as making the RHS re-entrant (non-updatable).
1128 rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
1129 rhsIsNonUpd (Note (SCC _) e) = False
1130 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1131 rhsIsNonUpd other_expr
1132 = go other_expr 0 []
1134 go (Var f) n_args args = idAppIsNonUpd f n_args args
1136 go (App f a) n_args args
1137 | isTypeArg a = go f n_args args
1138 | otherwise = go f (n_args + 1) (a:args)
1140 go (Note (SCC _) f) n_args args = False
1141 go (Note _ f) n_args args = go f n_args args
1143 go other n_args args = False
1145 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1146 idAppIsNonUpd id n_val_args args
1147 | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
1148 | otherwise = n_val_args < idArity id
1150 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1151 isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
1152 -- Top-level constructor applications can usually be allocated
1153 -- statically, but they can't if
1154 -- a) the constructor, or any of the arguments, come from another DLL
1155 -- b) any of the arguments are LitLits
1156 -- (because we can't refer to static labels in other DLLs).
1157 -- If this happens we simply make the RHS into an updatable thunk,
1158 -- and 'exectute' it rather than allocating it statically.
1159 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1162 isCrossDllArg :: CoreExpr -> Bool
1163 -- True if somewhere in the expression there's a cross-DLL reference
1164 isCrossDllArg (Type _) = False
1165 isCrossDllArg (Var v) = isDllName (idName v)
1166 isCrossDllArg (Note _ e) = isCrossDllArg e
1167 isCrossDllArg (Lit lit) = isLitLitLit lit
1168 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
1169 isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam