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 )
25 import CostCentre ( noCCS )
28 import DataCon ( dataConWrapId )
29 import IdInfo ( OccInfo(..) )
30 import TysPrim ( foreignObjPrimTyCon )
31 import Maybes ( maybeToBool )
32 import Name ( getOccName, isExternallyVisibleName, isDllName )
33 import OccName ( occNameUserString )
34 import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
35 import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
36 import FastTypes hiding ( fastOr )
39 import List ( partition )
44 %************************************************************************
46 \subsection[live-vs-free-doc]{Documentation}
48 %************************************************************************
50 (There is other relevant documentation in codeGen/CgLetNoEscape.)
52 The actual Stg datatype is decorated with {\em live variable}
53 information, as well as {\em free variable} information. The two are
54 {\em not} the same. Liveness is an operational property rather than a
55 semantic one. A variable is live at a particular execution point if
56 it can be referred to {\em directly} again. In particular, a dead
57 variable's stack slot (if it has one):
60 should be stubbed to avoid space leaks, and
62 may be reused for something else.
65 There ought to be a better way to say this. Here are some examples:
72 Just after the `in', v is live, but q is dead. If the whole of that
73 let expression was enclosed in a case expression, thus:
75 case (let v = [q] \[x] -> e in ...v...) of
78 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
79 we'll return later to the @alts@ and need it.
81 Let-no-escapes make this a bit more interesting:
83 let-no-escape v = [q] \ [x] -> e
87 Here, @q@ is still live at the `in', because @v@ is represented not by
88 a closure but by the current stack state. In other words, if @v@ is
89 live then so is @q@. Furthermore, if @e@ mentions an enclosing
90 let-no-escaped variable, then {\em its} free variables are also live
93 %************************************************************************
95 \subsection[caf-info]{Collecting live CAF info}
97 %************************************************************************
99 In this pass we also collect information on which CAFs are live for
100 constructing SRTs (see SRT.lhs).
102 A top-level Id has CafInfo, which is
104 - MayHaveCafRefs, if it may refer indirectly to
106 - NoCafRefs if it definitely doesn't
108 we collect the CafInfo first by analysing the original Core expression, and
109 also place this information in the environment.
111 During CoreToStg, we then pin onto each binding and case expression, a
112 list of Ids which represents the "live" CAFs at that point. The meaning
113 of "live" here is the same as for live variables, see above (which is
114 why it's convenient to collect CAF information here rather than elsewhere).
116 The later SRT pass takes these lists of Ids and uses them to construct
117 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
120 %************************************************************************
122 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
124 %************************************************************************
127 coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
130 where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm
132 coreExprToStg :: CoreExpr -> StgExpr
134 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
138 :: IdEnv HowBound -- environment for the bindings
140 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
142 coreTopBindsToStg env [] = (env, emptyFVInfo, [])
143 coreTopBindsToStg env (b:bs)
144 = (env2, fvs1, b':bs')
146 -- env accumulates down the list of binds, fvs accumulates upwards
147 (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
148 (env2, fvs1, bs') = coreTopBindsToStg env1 bs
153 -> FreeVarsInfo -- Info about the body
155 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
157 coreTopBindToStg env body_fvs (NonRec id rhs)
159 caf_info = hasCafRefs env rhs
160 arity = exprArity rhs
162 env' = extendVarEnv env id (LetBound how_bound emptyLVS arity)
164 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
165 | otherwise = TopLevelNoCafs
167 (stg_rhs, fvs', cafs) =
169 coreToStgRhs body_fvs TopLevel (id,rhs)
170 `thenLne` \ (stg_rhs, fvs', _) ->
171 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
172 returnLne (stg_rhs, fvs', cafs)
175 bind = StgNonRec (SRTEntries cafs) id stg_rhs
177 ASSERT2(consistent caf_info bind, ppr id)
178 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
179 (env', fvs' `unionFVInfo` body_fvs, bind)
181 coreTopBindToStg env body_fvs (Rec pairs)
183 (binders, rhss) = unzip pairs
185 -- to calculate caf_info, we initially map all the binders to
187 env1 = extendVarEnvList env
188 [ (b, LetBound TopLevelNoCafs emptyLVS (error "no arity"))
191 caf_info = hasCafRefss env1{-NB: not env'-} rhss
193 env' = extendVarEnvList env
194 [ (b, LetBound how_bound emptyLVS (exprArity rhs))
197 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
198 | otherwise = TopLevelNoCafs
200 (stg_rhss, fvs', cafs)
202 mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
203 `thenLne` \ (stg_rhss, fvss', _) ->
204 let fvs' = unionFVInfos fvss' in
205 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
206 returnLne (stg_rhss, fvs', cafs)
209 bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
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 bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr
234 bogus_expr = (StgLit (MachInt 1))
236 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
239 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
240 = StgRhsClosure noCCS binder_info
245 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
246 | isNotTopLevel top || not (isDllConApp con args)
247 = StgRhsCon noCCS con args
249 mkStgRhs top rhs_fvs binder_info rhs
250 = StgRhsClosure noCCS binder_info
255 updatable args body | null args && isPAP body = ReEntrant
256 | otherwise = Updatable
258 upd = if isOnceDem dem
259 then (if isNotTop toplev
260 then SingleEntry -- HA! Paydirt for "dem"
263 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
267 -- For now we forbid SingleEntry CAFs; they tickle the
268 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
269 -- and I don't understand why. There's only one SE_CAF (well,
270 -- only one that tickled a great gaping bug in an earlier attempt
271 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
272 -- specifically Main.lvl6 in spectral/cryptarithm2.
273 -- So no great loss. KSW 2000-07.
277 Detect thunks which will reduce immediately to PAPs, and make them
278 non-updatable. This has several advantages:
280 - the non-updatable thunk behaves exactly like the PAP,
282 - the thunk is more efficient to enter, because it is
283 specialised to the task.
285 - we save one update frame, one stg_update_PAP, one update
286 and lots of PAP_enters.
288 - in the case where the thunk is top-level, we save building
289 a black hole and futhermore the thunk isn't considered to
290 be a CAF any more, so it doesn't appear in any SRTs.
292 We do it here, because the arity information is accurate, and we need
293 to do it before the SRT pass to save the SRT entries associated with
297 isPAP (StgApp f args) = idArity f > length args
302 -- ---------------------------------------------------------------------------
304 -- ---------------------------------------------------------------------------
309 -> LneM (StgExpr, -- Decorated STG expr
310 FreeVarsInfo, -- Its free vars (NB free, not live)
311 EscVarsSet) -- Its escapees, a subset of its free vars;
312 -- also a subset of the domain of the envt
313 -- because we are only interested in the escapees
314 -- for vars which might be turned into
315 -- let-no-escaped ones.
318 The second and third components can be derived in a simple bottom up pass, not
319 dependent on any decisions about which variables will be let-no-escaped or
320 not. The first component, that is, the decorated expression, may then depend
321 on these components, but it in turn is not scrutinised as the basis for any
322 decisions. Hence no black holes.
325 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
326 coreToStgExpr (Var v) = coreToStgApp Nothing v []
328 coreToStgExpr expr@(App _ _)
329 = coreToStgApp Nothing f args
331 (f, args) = myCollectArgs expr
333 coreToStgExpr expr@(Lam _ _)
334 = let (args, body) = myCollectBinders expr
335 args' = filterStgBinders args
337 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
338 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
340 set_of_args = mkVarSet args'
341 fvs = args' `minusFVBinders` body_fvs
342 escs = body_escs `minusVarSet` set_of_args
343 result_expr | null args' = body
344 | otherwise = StgLam (exprType expr) args' body
346 returnLne (result_expr, fvs, escs)
348 coreToStgExpr (Note (SCC cc) expr)
349 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
350 returnLne (StgSCC cc expr2, fvs, escs) )
352 coreToStgExpr (Note other_note expr)
356 -- Cases require a little more real work.
358 coreToStgExpr (Case scrut bndr alts)
359 = extendVarEnvLne [(bndr, CaseBound)] $
360 vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
361 freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
363 -- determine whether the default binder is dead or not
364 -- This helps the code generator to avoid generating an assignment
365 -- for the case binder (is extremely rare cases) ToDo: remove.
366 bndr'= if (bndr `elementOfFVInfo` alts_fvs)
368 else bndr `setIdOccInfo` IAmDead
370 -- Don't consider the default binder as being 'live in alts',
371 -- since this is from the point of view of the case expr, where
372 -- the default binder is not free.
373 live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
375 -- we tell the scrutinee that everything live in the alts
376 -- is live in it, too.
377 setVarsLiveInCont (live_in_alts,alts_caf_refs) (
378 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
379 freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
380 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
382 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
384 let srt = SRTEntries alts_caf_refs
387 StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
388 bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
389 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
390 -- You might think we should have scrut_escs, not
391 -- (getFVSet scrut_fvs), but actually we can't call, and
392 -- then return from, a let-no-escape thing.
395 scrut_ty = idType bndr
396 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
398 vars_alts (alts,deflt)
400 = mapAndUnzip3Lne vars_prim_alt alts
401 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
403 alts_fvs = unionFVInfos alts_fvs_list
404 alts_escs = unionVarSets alts_escs_list
406 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
408 mkStgPrimAlts scrut_ty alts2 deflt2,
409 alts_fvs `unionFVInfo` deflt_fvs,
410 alts_escs `unionVarSet` deflt_escs
414 = mapAndUnzip3Lne vars_alg_alt alts
415 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
417 alts_fvs = unionFVInfos alts_fvs_list
418 alts_escs = unionVarSets alts_escs_list
420 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
422 mkStgAlgAlts scrut_ty alts2 deflt2,
423 alts_fvs `unionFVInfo` deflt_fvs,
424 alts_escs `unionVarSet` deflt_escs
428 vars_prim_alt (LitAlt lit, _, rhs)
429 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
430 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
432 vars_alg_alt (DataAlt con, binders, rhs)
434 -- remove type variables
435 binders' = filterStgBinders binders
437 extendVarEnvLne [(b, CaseBound) | b <- binders'] $
438 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
440 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
441 -- records whether each param is used in the RHS
444 (con, binders', good_use_mask, rhs2),
445 binders' `minusFVBinders` rhs_fvs,
446 rhs_escs `minusVarSet` mkVarSet binders'
447 -- ToDo: remove the minusVarSet;
448 -- since escs won't include any of these binders
450 vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
453 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
455 vars_deflt (Just rhs)
456 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
457 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
460 Lets not only take quite a bit of work, but this is where we convert
461 then to let-no-escapes, if we wish.
463 (Meanwhile, we don't expect to see let-no-escapes...)
465 coreToStgExpr (Let bind body)
466 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
467 coreToStgLet no_binder_escapes bind body
468 ) `thenLne` \ (new_let, fvs, escs, _) ->
470 returnLne (new_let, fvs, escs)
473 If we've got a case containing a _ccall_GC_ primop, we need to
474 ensure that the arguments are kept live for the duration of the
475 call. This only an issue
478 isForeignObjArg :: Id -> Bool
479 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
481 isForeignObjPrimTy ty
482 = case splitTyConApp_maybe ty of
483 Just (tycon, _) -> tycon == foreignObjPrimTyCon
488 mkStgAlgAlts ty alts deflt
490 -- Get the tycon from the data con
491 (dc, _, _, _) : _rest
492 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
494 -- Otherwise just do your best
495 [] -> case splitTyConApp_maybe (repType ty) of
496 Just (tc,_) | isAlgTyCon tc
497 -> StgAlgAlts (Just tc) alts deflt
499 -> StgAlgAlts Nothing alts deflt
501 mkStgPrimAlts ty alts deflt
502 = StgPrimAlts (tyConAppTyCon ty) alts deflt
506 -- ---------------------------------------------------------------------------
508 -- ---------------------------------------------------------------------------
512 :: Maybe UpdateFlag -- Just upd <=> this application is
513 -- the rhs of a thunk binding
514 -- x = [...] \upd [] -> the_app
515 -- with specified update flag
517 -> [CoreArg] -- Arguments
518 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
520 coreToStgApp maybe_thunk_body f args
521 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
522 lookupVarLne f `thenLne` \ how_bound ->
526 not_letrec_bound = not (isLetBound how_bound)
527 fun_fvs = singletonFVInfo f how_bound fun_occ
529 -- Mostly, the arity info of a function is in the fn's IdInfo
530 -- But new bindings introduced by CoreSat may not have no
531 -- arity info; it would do us no good anyway. For example:
532 -- let f = \ab -> e in f
533 -- No point in having correct arity info for f!
534 -- Hence the hasArity stuff below.
535 f_arity = case how_bound of
536 LetBound _ _ arity -> arity
540 | not_letrec_bound = noBinderInfo -- Uninteresting variable
541 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
542 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
545 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
546 | f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
547 -- saturated call doesn't escape
548 -- (let-no-escape applies to 'thunks' too)
550 | otherwise = unitVarSet f -- Inexact application; it does escape
552 -- At the moment of the call:
554 -- either the function is *not* let-no-escaped, in which case
555 -- nothing is live except live_in_cont
556 -- or the function *is* let-no-escaped in which case the
557 -- variables it uses are live, but still the function
558 -- itself is not. PS. In this case, the function's
559 -- live vars should already include those of the
560 -- continuation, but it does no harm to just union the
563 app = case globalIdDetails f of
564 DataConId dc -> StgConApp dc args'
565 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
566 _other -> StgApp f args'
571 fun_fvs `unionFVInfo` args_fvs,
572 fun_escs `unionVarSet` (getFVSet args_fvs)
573 -- All the free vars of the args are disqualified
574 -- from being let-no-escaped.
579 -- ---------------------------------------------------------------------------
581 -- This is the guy that turns applications into A-normal form
582 -- ---------------------------------------------------------------------------
584 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
586 = returnLne ([], emptyFVInfo)
588 coreToStgArgs (Type ty : args) -- Type argument
589 = coreToStgArgs args `thenLne` \ (args', fvs) ->
590 if opt_KeepStgTypes then
591 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
593 returnLne (args', fvs)
595 coreToStgArgs (arg : args) -- Non-type argument
596 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
597 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
599 fvs = args_fvs `unionFVInfo` arg_fvs
600 stg_arg = case arg' of
601 StgApp v [] -> StgVarArg v
602 StgConApp con [] -> StgVarArg (dataConWrapId con)
603 StgLit lit -> StgLitArg lit
604 _ -> pprPanic "coreToStgArgs" (ppr arg)
606 returnLne (stg_arg : stg_args, fvs)
609 -- ---------------------------------------------------------------------------
610 -- The magic for lets:
611 -- ---------------------------------------------------------------------------
614 :: Bool -- True <=> yes, we are let-no-escaping this let
615 -> CoreBind -- bindings
617 -> LneM (StgExpr, -- new let
618 FreeVarsInfo, -- variables free in the whole let
619 EscVarsSet, -- variables that escape from the whole let
620 Bool) -- True <=> none of the binders in the bindings
621 -- is among the escaping vars
623 coreToStgLet let_no_escape bind body
624 = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
626 -- Do the bindings, setting live_in_cont to empty if
627 -- we ain't in a let-no-escape world
628 getVarsLiveInCont `thenLne` \ live_in_cont ->
629 setVarsLiveInCont (if let_no_escape
632 (vars_bind rec_body_fvs bind)
633 `thenLne` \ ( bind2, bind_fvs, bind_escs
634 , bind_lvs, bind_cafs, env_ext) ->
637 extendVarEnvLne env_ext (
638 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
639 freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
641 returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
642 body2, body_fvs, body_escs, body_lvs)
645 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
646 body2, body_fvs, body_escs, body_lvs) ->
649 -- Compute the new let-expression
651 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
652 | otherwise = StgLet bind2 body2
655 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
658 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
660 real_bind_escs = if let_no_escape then
664 -- Everything escapes which is free in the bindings
666 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
668 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
671 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
674 -- Debugging code as requested by Andrew Kennedy
675 checked_no_binder_escapes
676 | not no_binder_escapes && any is_join_var binders
677 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
679 | otherwise = no_binder_escapes
681 checked_no_binder_escapes = no_binder_escapes
684 -- Mustn't depend on the passed-in let_no_escape flag, since
685 -- no_binder_escapes is used by the caller to derive the flag!
691 checked_no_binder_escapes
694 set_of_binders = mkVarSet binders
695 binders = case bind of
696 NonRec binder rhs -> [binder]
697 Rec pairs -> map fst pairs
699 mk_binding bind_lvs bind_cafs binder rhs
700 = (binder, LetBound NotTopLevelBound -- Not top level
701 live_vars (exprArity rhs)
704 live_vars = if let_no_escape then
705 (extendVarSet bind_lvs binder, bind_cafs)
707 (unitVarSet binder, emptyVarSet)
709 vars_bind :: FreeVarsInfo -- Free var info for body of binding
713 EscVarsSet, -- free vars; escapee vars
714 StgLiveVars, -- vars live in binding
715 IdSet, -- CAFs live in binding
716 [(Id, HowBound)]) -- extension to environment
719 vars_bind body_fvs (NonRec binder rhs)
720 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
721 `thenLne` \ (rhs2, bind_fvs, escs) ->
723 freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
725 env_ext_item@(binder', _) = mk_binding bind_lvs bind_cafs binder rhs
727 returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
728 bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
731 vars_bind body_fvs (Rec pairs)
732 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
734 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
735 binders = map fst pairs
736 env_ext = [ mk_binding bind_lvs bind_cafs b rhs
739 extendVarEnvLne env_ext (
740 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
741 `thenLne` \ (rhss2, fvss, escss) ->
743 bind_fvs = unionFVInfos fvss
744 escs = unionVarSets escss
746 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
747 `thenLne` \ (bind_lvs, bind_cafs) ->
749 returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
750 bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
754 is_join_var :: Id -> Bool
755 -- A hack (used only for compiler debuggging) to tell if
756 -- a variable started life as a join point ($j)
757 is_join_var j = occNameUserString (getOccName j) == "$j"
760 %************************************************************************
762 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
764 %************************************************************************
766 There's a lot of stuff to pass around, so we use this @LneM@ monad to
767 help. All the stuff here is only passed *down*.
770 type LneM a = IdEnv HowBound
771 -> (StgLiveVars, -- vars live in continuation
772 IdSet) -- cafs live in continuation
781 (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
782 Arity -- its arity (local Ids don't have arity info at this point)
784 isLetBound (LetBound _ _ _) = True
785 isLetBound other = False
788 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
789 variables that are live if x is live. For "normal" variables that is
790 just x alone. If x is a let-no-escaped variable then x is represented
791 by a code pointer and a stack pointer (well, one for each stack). So
792 all of the variables needed in the execution of x are live if x is,
793 and are therefore recorded in the LetBound constructor; x itself
796 The set of live variables is guaranteed ot have no further let-no-escaped
799 The std monad functions:
801 initLne :: IdEnv HowBound -> LneM a -> a
802 initLne env m = m env emptyLVS
804 emptyLVS = (emptyVarSet,emptyVarSet)
806 {-# INLINE thenLne #-}
807 {-# INLINE returnLne #-}
809 returnLne :: a -> LneM a
810 returnLne e env lvs_cont = e
812 thenLne :: LneM a -> (a -> LneM b) -> LneM b
813 thenLne m k env lvs_cont
814 = k (m env lvs_cont) env lvs_cont
816 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
817 mapLne f [] = returnLne []
819 = f x `thenLne` \ r ->
820 mapLne f xs `thenLne` \ rs ->
823 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
825 mapAndUnzipLne f [] = returnLne ([],[])
826 mapAndUnzipLne f (x:xs)
827 = f x `thenLne` \ (r1, r2) ->
828 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
829 returnLne (r1:rs1, r2:rs2)
831 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
833 mapAndUnzip3Lne f [] = returnLne ([],[],[])
834 mapAndUnzip3Lne f (x:xs)
835 = f x `thenLne` \ (r1, r2, r3) ->
836 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
837 returnLne (r1:rs1, r2:rs2, r3:rs3)
839 fixLne :: (a -> LneM a) -> LneM a
840 fixLne expr env lvs_cont
843 result = expr result env lvs_cont
846 Functions specific to this monad:
849 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
850 getVarsLiveInCont env lvs_cont = lvs_cont
852 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
853 setVarsLiveInCont new_lvs_cont expr env lvs_cont
854 = expr env new_lvs_cont
856 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
857 extendVarEnvLne ids_w_howbound expr env lvs_cont
858 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
860 lookupVarLne :: Id -> LneM HowBound
861 lookupVarLne v env lvs_cont
863 case (lookupVarEnv env v) of
865 Nothing -> ImportBound
868 -- The result of lookupLiveVarsForSet, a set of live variables, is
869 -- only ever tacked onto a decorated expression. It is never used as
870 -- the basis of a control decision, which might give a black hole.
872 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
873 freeVarsToLiveVars fvs env live_in_cont
874 = returnLne (lvs, cafs) env live_in_cont
876 (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
877 (local, global) = partition isLocalId (allFVs fvs)
879 (lvs_from_fvs, caf_extras) = unzip (map do_one local)
881 lvs = unionVarSets lvs_from_fvs
882 `unionVarSet` lvs_cont
884 cafs = mkVarSet (filter is_caf_one global)
885 `unionVarSet` (unionVarSets caf_extras)
886 `unionVarSet` cafs_cont
889 = case (lookupVarEnv env v) of
890 Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
891 Just _ -> (unitVarSet v, emptyVarSet)
892 Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
895 = case lookupVarEnv env v of
896 Just (LetBound TopLevelHasCafs (lvs,_) _) ->
897 ASSERT( isEmptyVarSet lvs ) True
898 Just (LetBound _ _ _) -> False
899 _otherwise -> mayHaveCafRefs (idCafInfo v)
902 %************************************************************************
904 \subsection[Free-var info]{Free variable information}
906 %************************************************************************
909 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
910 -- If f is mapped to noBinderInfo, that means
911 -- that f *is* mentioned (else it wouldn't be in the
912 -- IdEnv at all), but perhaps in an unsaturated applications.
914 -- All case/lambda-bound things are also mapped to
915 -- noBinderInfo, since we aren't interested in their
918 -- For ILX we track free var info for type variables too;
919 -- hence VarEnv not IdEnv
927 type EscVarsSet = IdSet
931 emptyFVInfo :: FreeVarsInfo
932 emptyFVInfo = emptyVarEnv
934 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
935 singletonFVInfo id ImportBound info
936 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
937 | otherwise = emptyVarEnv
938 singletonFVInfo id (LetBound top_level _ _) info
939 = unitVarEnv id (id, top_level, info)
940 singletonFVInfo id other info
941 = unitVarEnv id (id, NotTopLevelBound, info)
943 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
944 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
946 add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
948 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
949 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
951 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
952 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
954 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
955 minusFVBinders vs fv = foldr minusFVBinder fv vs
957 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
958 minusFVBinder v fv | isId v && opt_KeepStgTypes
959 = (fv `delVarEnv` v) `unionFVInfo`
960 tyvarFVInfo (tyVarsOfType (idType v))
961 | otherwise = fv `delVarEnv` v
962 -- When removing a binder, remember to add its type variables
963 -- c.f. CoreFVs.delBinderFV
965 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
966 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
968 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
969 -- Find how the given Id is used.
970 -- Externally visible things may be used any old how
972 | isExternallyVisibleName (idName id) = noBinderInfo
973 | otherwise = case lookupVarEnv fvs id of
974 Nothing -> noBinderInfo
975 Just (_,_,info) -> info
977 allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
978 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
980 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
981 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
983 getFVSet :: FreeVarsInfo -> IdSet
984 getFVSet fvs = mkVarSet (getFVs fvs)
986 plusFVInfo (id1,top1,info1) (id2,top2,info2)
987 = ASSERT (id1 == id2 && top1 == top2)
988 (id1, top1, combineStgBinderInfo info1 info2)
993 filterStgBinders :: [Var] -> [Var]
994 filterStgBinders bndrs
995 | opt_KeepStgTypes = bndrs
996 | otherwise = filter isId bndrs
1001 -- Ignore all notes except SCC
1002 myCollectBinders expr
1005 go bs (Lam b e) = go (b:bs) e
1006 go bs e@(Note (SCC _) _) = (reverse bs, e)
1007 go bs (Note _ e) = go bs e
1008 go bs e = (reverse bs, e)
1010 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1011 -- We assume that we only have variables
1012 -- in the function position by now
1016 go (Var v) as = (v, as)
1017 go (App f a) as = go f (a:as)
1018 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1019 go (Note n e) as = go e as
1020 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1023 %************************************************************************
1025 \subsection{Figuring out CafInfo for an expression}
1027 %************************************************************************
1029 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1030 We mark such things as `MayHaveCafRefs' because this information is
1031 used to decide whether a particular closure needs to be referenced
1034 There are two reasons for setting MayHaveCafRefs:
1035 a) The RHS is a CAF: a top-level updatable thunk.
1036 b) The RHS refers to something that MayHaveCafRefs
1038 Possible improvement: In an effort to keep the number of CAFs (and
1039 hence the size of the SRTs) down, we could also look at the expression and
1040 decide whether it requires a small bounded amount of heap, so we can ignore
1041 it as a CAF. In these cases however, we would need to use an additional
1042 CAF list to keep track of non-collectable CAFs.
1045 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1046 -- Only called for the RHS of top-level lets
1047 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1048 -- predicate returns True for a given Id if we look at this Id when
1049 -- calculating the result. Used to *avoid* looking at the CafInfo
1050 -- field for an Id that is part of the current recursive group.
1053 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1054 | otherwise = NoCafRefs
1056 -- used for recursive groups. The whole group is set to
1057 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1058 -- refers to any CAFs.
1060 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1061 | otherwise = NoCafRefs
1063 -- cafRefs compiles to beautiful code :)
1066 | isLocalId id = fastBool False
1068 case lookupVarEnv p id of
1069 Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1070 Just (LetBound _ _ _) -> fastBool False
1071 Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
1073 cafRefs p (Lit l) = fastBool False
1074 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1075 cafRefs p (Lam x e) = cafRefs p e
1076 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1077 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1078 (cafRefss p) (rhssOfAlts alts)
1079 cafRefs p (Note n e) = cafRefs p e
1080 cafRefs p (Type t) = fastBool False
1082 cafRefss p [] = fastBool False
1083 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1085 -- hack for lazy-or over FastBool.
1086 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1088 isCAF :: CoreExpr -> Bool
1089 -- Only called for the RHS of top-level lets
1090 isCAF e = not (rhsIsNonUpd e)
1091 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1094 rhsIsNonUpd :: CoreExpr -> Bool
1095 -- True => Value-lambda, constructor, PAP
1096 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1097 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1099 -- b) (C x xs), where C is a contructors is updatable if the application is
1100 -- dynamic: see isDynConApp
1102 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1104 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
1105 rhsIsNonUpd (Note (SCC _) e) = False
1106 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1107 rhsIsNonUpd other_expr
1108 = go other_expr 0 []
1110 go (Var f) n_args args = idAppIsNonUpd f n_args args
1112 go (App f a) n_args args
1113 | isTypeArg a = go f n_args args
1114 | otherwise = go f (n_args + 1) (a:args)
1116 go (Note (SCC _) f) n_args args = False
1117 go (Note _ f) n_args args = go f n_args args
1119 go other n_args args = False
1121 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1122 idAppIsNonUpd id n_val_args args
1123 | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1124 | otherwise = n_val_args < idArity id
1126 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1127 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1128 -- Top-level constructor applications can usually be allocated
1129 -- statically, but they can't if
1130 -- a) the constructor, or any of the arguments, come from another DLL
1131 -- b) any of the arguments are LitLits
1132 -- (because we can't refer to static labels in other DLLs).
1133 -- If this happens we simply make the RHS into an updatable thunk,
1134 -- and 'exectute' it rather than allocating it statically.
1135 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1138 isDynArg :: CoreExpr -> Bool
1139 isDynArg (Var v) = isDllName (idName v)
1140 isDynArg (Note _ e) = isDynArg e
1141 isDynArg (Lit lit) = isLitLitLit lit
1142 isDynArg (App e _) = isDynArg e -- must be a type app
1143 isDynArg (Lam _ e) = isDynArg e -- must be a type lam