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 (_, _, 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, fvs2, 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 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)
470 If we've got a case containing a _ccall_GC_ primop, we need to
471 ensure that the arguments are kept live for the duration of the
472 call. This only an issue
475 isForeignObjArg :: Id -> Bool
476 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
478 isForeignObjPrimTy ty
479 = case splitTyConApp_maybe ty of
480 Just (tycon, _) -> tycon == foreignObjPrimTyCon
485 mkStgAlgAlts ty alts deflt
487 -- Get the tycon from the data con
488 (dc, _, _, _) : _rest
489 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
491 -- Otherwise just do your best
492 [] -> case splitTyConApp_maybe (repType ty) of
493 Just (tc,_) | isAlgTyCon tc
494 -> StgAlgAlts (Just tc) alts deflt
496 -> StgAlgAlts Nothing alts deflt
498 mkStgPrimAlts ty alts deflt
499 = StgPrimAlts (tyConAppTyCon ty) alts deflt
503 -- ---------------------------------------------------------------------------
505 -- ---------------------------------------------------------------------------
509 :: Maybe UpdateFlag -- Just upd <=> this application is
510 -- the rhs of a thunk binding
511 -- x = [...] \upd [] -> the_app
512 -- with specified update flag
514 -> [CoreArg] -- Arguments
515 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
517 coreToStgApp maybe_thunk_body f args
518 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
519 lookupVarLne f `thenLne` \ how_bound ->
523 not_letrec_bound = not (isLetBound how_bound)
524 fun_fvs = singletonFVInfo f how_bound fun_occ
526 -- Mostly, the arity info of a function is in the fn's IdInfo
527 -- But new bindings introduced by CoreSat may not have no
528 -- arity info; it would do us no good anyway. For example:
529 -- let f = \ab -> e in f
530 -- No point in having correct arity info for f!
531 -- Hence the hasArity stuff below.
532 f_arity = case how_bound of
533 LetBound _ _ arity -> arity
537 | not_letrec_bound = noBinderInfo -- Uninteresting variable
538 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
539 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
542 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
543 | f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
544 -- saturated call doesn't escape
545 -- (let-no-escape applies to 'thunks' too)
547 | otherwise = unitVarSet f -- Inexact application; it does escape
549 -- At the moment of the call:
551 -- either the function is *not* let-no-escaped, in which case
552 -- nothing is live except live_in_cont
553 -- or the function *is* let-no-escaped in which case the
554 -- variables it uses are live, but still the function
555 -- itself is not. PS. In this case, the function's
556 -- live vars should already include those of the
557 -- continuation, but it does no harm to just union the
560 app = case globalIdDetails f of
561 DataConId dc -> StgConApp dc args'
562 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
563 _other -> StgApp f args'
568 fun_fvs `unionFVInfo` args_fvs,
569 fun_escs `unionVarSet` (getFVSet args_fvs)
570 -- All the free vars of the args are disqualified
571 -- from being let-no-escaped.
576 -- ---------------------------------------------------------------------------
578 -- This is the guy that turns applications into A-normal form
579 -- ---------------------------------------------------------------------------
581 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
583 = returnLne ([], emptyFVInfo)
585 coreToStgArgs (Type ty : args) -- Type argument
586 = coreToStgArgs args `thenLne` \ (args', fvs) ->
587 if opt_KeepStgTypes then
588 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
590 returnLne (args', fvs)
592 coreToStgArgs (arg : args) -- Non-type argument
593 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
594 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
596 fvs = args_fvs `unionFVInfo` arg_fvs
597 stg_arg = case arg' of
598 StgApp v [] -> StgVarArg v
599 StgConApp con [] -> StgVarArg (dataConWrapId con)
600 StgLit lit -> StgLitArg lit
601 _ -> pprPanic "coreToStgArgs" (ppr arg)
603 returnLne (stg_arg : stg_args, fvs)
606 -- ---------------------------------------------------------------------------
607 -- The magic for lets:
608 -- ---------------------------------------------------------------------------
611 :: Bool -- True <=> yes, we are let-no-escaping this let
612 -> CoreBind -- bindings
614 -> LneM (StgExpr, -- new let
615 FreeVarsInfo, -- variables free in the whole let
616 EscVarsSet, -- variables that escape from the whole let
617 Bool) -- True <=> none of the binders in the bindings
618 -- is among the escaping vars
620 coreToStgLet let_no_escape bind body
621 = fixLne (\ ~(_, _, _, _, _, _, rec_body_fvs, _, _) ->
623 -- Do the bindings, setting live_in_cont to empty if
624 -- we ain't in a let-no-escape world
625 getVarsLiveInCont `thenLne` \ live_in_cont ->
626 setVarsLiveInCont (if let_no_escape
629 (vars_bind rec_body_fvs bind)
630 `thenLne` \ ( bind2, bind_fvs, bind_escs
631 , bind_lvs, bind_cafs, env_ext) ->
634 extendVarEnvLne env_ext (
635 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
636 freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
638 returnLne (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
639 body2, body_fvs, body_escs, body_lvs)
642 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs, bind_cafs,
643 body2, body_fvs, body_escs, body_lvs) ->
646 -- Compute the new let-expression
648 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
649 | otherwise = StgLet bind2 body2
652 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
655 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
657 real_bind_escs = if let_no_escape then
661 -- Everything escapes which is free in the bindings
663 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
665 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
668 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
671 -- Debugging code as requested by Andrew Kennedy
672 checked_no_binder_escapes
673 | not no_binder_escapes && any is_join_var binders
674 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
676 | otherwise = no_binder_escapes
678 checked_no_binder_escapes = no_binder_escapes
681 -- Mustn't depend on the passed-in let_no_escape flag, since
682 -- no_binder_escapes is used by the caller to derive the flag!
688 checked_no_binder_escapes
691 set_of_binders = mkVarSet binders
692 binders = case bind of
693 NonRec binder rhs -> [binder]
694 Rec pairs -> map fst pairs
696 mk_binding bind_lvs bind_cafs binder rhs
697 = (binder, LetBound NotTopLevelBound -- Not top level
698 live_vars (exprArity rhs)
701 live_vars = if let_no_escape then
702 (extendVarSet bind_lvs binder, bind_cafs)
704 (unitVarSet binder, emptyVarSet)
706 vars_bind :: FreeVarsInfo -- Free var info for body of binding
710 EscVarsSet, -- free vars; escapee vars
711 StgLiveVars, -- vars live in binding
712 IdSet, -- CAFs live in binding
713 [(Id, HowBound)]) -- extension to environment
716 vars_bind body_fvs (NonRec binder rhs)
717 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
718 `thenLne` \ (rhs2, bind_fvs, escs) ->
720 freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
722 env_ext_item@(binder', _) = mk_binding bind_lvs bind_cafs binder rhs
724 returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
725 bind_fvs, escs, bind_lvs, bind_cafs, [env_ext_item])
728 vars_bind body_fvs (Rec pairs)
729 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, bind_cafs, _) ->
731 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
732 binders = map fst pairs
733 env_ext = [ mk_binding bind_lvs bind_cafs b rhs
736 extendVarEnvLne env_ext (
737 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
738 `thenLne` \ (rhss2, fvss, escss) ->
740 bind_fvs = unionFVInfos fvss
741 escs = unionVarSets escss
743 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
744 `thenLne` \ (bind_lvs, bind_cafs) ->
746 returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
747 bind_fvs, escs, bind_lvs, bind_cafs, env_ext)
751 is_join_var :: Id -> Bool
752 -- A hack (used only for compiler debuggging) to tell if
753 -- a variable started life as a join point ($j)
754 is_join_var j = occNameUserString (getOccName j) == "$j"
757 %************************************************************************
759 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
761 %************************************************************************
763 There's a lot of stuff to pass around, so we use this @LneM@ monad to
764 help. All the stuff here is only passed *down*.
767 type LneM a = IdEnv HowBound
768 -> (StgLiveVars, -- vars live in continuation
769 IdSet) -- cafs live in continuation
778 (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
779 Arity -- its arity (local Ids don't have arity info at this point)
781 isLetBound (LetBound _ _ _) = True
782 isLetBound other = False
785 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
786 variables that are live if x is live. For "normal" variables that is
787 just x alone. If x is a let-no-escaped variable then x is represented
788 by a code pointer and a stack pointer (well, one for each stack). So
789 all of the variables needed in the execution of x are live if x is,
790 and are therefore recorded in the LetBound constructor; x itself
793 The set of live variables is guaranteed ot have no further let-no-escaped
796 The std monad functions:
798 initLne :: IdEnv HowBound -> LneM a -> a
799 initLne env m = m env emptyLVS
801 emptyLVS = (emptyVarSet,emptyVarSet)
803 {-# INLINE thenLne #-}
804 {-# INLINE returnLne #-}
806 returnLne :: a -> LneM a
807 returnLne e env lvs_cont = e
809 thenLne :: LneM a -> (a -> LneM b) -> LneM b
810 thenLne m k env lvs_cont
811 = k (m env lvs_cont) env lvs_cont
813 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
814 mapLne f [] = returnLne []
816 = f x `thenLne` \ r ->
817 mapLne f xs `thenLne` \ rs ->
820 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
822 mapAndUnzipLne f [] = returnLne ([],[])
823 mapAndUnzipLne f (x:xs)
824 = f x `thenLne` \ (r1, r2) ->
825 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
826 returnLne (r1:rs1, r2:rs2)
828 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
830 mapAndUnzip3Lne f [] = returnLne ([],[],[])
831 mapAndUnzip3Lne f (x:xs)
832 = f x `thenLne` \ (r1, r2, r3) ->
833 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
834 returnLne (r1:rs1, r2:rs2, r3:rs3)
836 fixLne :: (a -> LneM a) -> LneM a
837 fixLne expr env lvs_cont
840 result = expr result env lvs_cont
843 Functions specific to this monad:
846 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
847 getVarsLiveInCont env lvs_cont = lvs_cont
849 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
850 setVarsLiveInCont new_lvs_cont expr env lvs_cont
851 = expr env new_lvs_cont
853 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
854 extendVarEnvLne ids_w_howbound expr env lvs_cont
855 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
857 lookupVarLne :: Id -> LneM HowBound
858 lookupVarLne v env lvs_cont
860 case (lookupVarEnv env v) of
862 Nothing -> ImportBound
865 -- The result of lookupLiveVarsForSet, a set of live variables, is
866 -- only ever tacked onto a decorated expression. It is never used as
867 -- the basis of a control decision, which might give a black hole.
869 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
870 freeVarsToLiveVars fvs env live_in_cont
871 = returnLne (lvs, cafs) env live_in_cont
873 (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
874 (local, global) = partition isLocalId (allFVs fvs)
876 (lvs_from_fvs, caf_extras) = unzip (map do_one local)
878 lvs = unionVarSets lvs_from_fvs
879 `unionVarSet` lvs_cont
881 cafs = mkVarSet (filter is_caf_one global)
882 `unionVarSet` (unionVarSets caf_extras)
883 `unionVarSet` cafs_cont
886 = case (lookupVarEnv env v) of
887 Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
888 Just _ -> (unitVarSet v, emptyVarSet)
889 Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
892 = case lookupVarEnv env v of
893 Just (LetBound TopLevelHasCafs (lvs,_) _) ->
894 ASSERT( isEmptyVarSet lvs ) True
895 Just (LetBound _ _ _) -> False
896 _otherwise -> mayHaveCafRefs (idCafInfo v)
899 %************************************************************************
901 \subsection[Free-var info]{Free variable information}
903 %************************************************************************
906 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
907 -- If f is mapped to noBinderInfo, that means
908 -- that f *is* mentioned (else it wouldn't be in the
909 -- IdEnv at all), but perhaps in an unsaturated applications.
911 -- All case/lambda-bound things are also mapped to
912 -- noBinderInfo, since we aren't interested in their
915 -- For ILX we track free var info for type variables too;
916 -- hence VarEnv not IdEnv
924 type EscVarsSet = IdSet
928 emptyFVInfo :: FreeVarsInfo
929 emptyFVInfo = emptyVarEnv
931 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
932 singletonFVInfo id ImportBound info
933 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
934 | otherwise = emptyVarEnv
935 singletonFVInfo id (LetBound top_level _ _) info
936 = unitVarEnv id (id, top_level, info)
937 singletonFVInfo id other info
938 = unitVarEnv id (id, NotTopLevelBound, info)
940 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
941 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
943 add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
945 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
946 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
948 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
949 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
951 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
952 minusFVBinders vs fv = foldr minusFVBinder fv vs
954 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
955 minusFVBinder v fv | isId v && opt_KeepStgTypes
956 = (fv `delVarEnv` v) `unionFVInfo`
957 tyvarFVInfo (tyVarsOfType (idType v))
958 | otherwise = fv `delVarEnv` v
959 -- When removing a binder, remember to add its type variables
960 -- c.f. CoreFVs.delBinderFV
962 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
963 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
965 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
966 -- Find how the given Id is used.
967 -- Externally visible things may be used any old how
969 | isExternallyVisibleName (idName id) = noBinderInfo
970 | otherwise = case lookupVarEnv fvs id of
971 Nothing -> noBinderInfo
972 Just (_,_,info) -> info
974 allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
975 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
977 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
978 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
980 getFVSet :: FreeVarsInfo -> IdSet
981 getFVSet fvs = mkVarSet (getFVs fvs)
983 plusFVInfo (id1,top1,info1) (id2,top2,info2)
984 = ASSERT (id1 == id2 && top1 == top2)
985 (id1, top1, combineStgBinderInfo info1 info2)
990 filterStgBinders :: [Var] -> [Var]
991 filterStgBinders bndrs
992 | opt_KeepStgTypes = bndrs
993 | otherwise = filter isId bndrs
998 -- Ignore all notes except SCC
999 myCollectBinders expr
1002 go bs (Lam b e) = go (b:bs) e
1003 go bs e@(Note (SCC _) _) = (reverse bs, e)
1004 go bs (Note _ e) = go bs e
1005 go bs e = (reverse bs, e)
1007 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1008 -- We assume that we only have variables
1009 -- in the function position by now
1013 go (Var v) as = (v, as)
1014 go (App f a) as = go f (a:as)
1015 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1016 go (Note n e) as = go e as
1017 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1020 %************************************************************************
1022 \subsection{Figuring out CafInfo for an expression}
1024 %************************************************************************
1026 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1027 We mark such things as `MayHaveCafRefs' because this information is
1028 used to decide whether a particular closure needs to be referenced
1031 There are two reasons for setting MayHaveCafRefs:
1032 a) The RHS is a CAF: a top-level updatable thunk.
1033 b) The RHS refers to something that MayHaveCafRefs
1035 Possible improvement: In an effort to keep the number of CAFs (and
1036 hence the size of the SRTs) down, we could also look at the expression and
1037 decide whether it requires a small bounded amount of heap, so we can ignore
1038 it as a CAF. In these cases however, we would need to use an additional
1039 CAF list to keep track of non-collectable CAFs.
1042 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1043 -- Only called for the RHS of top-level lets
1044 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1045 -- predicate returns True for a given Id if we look at this Id when
1046 -- calculating the result. Used to *avoid* looking at the CafInfo
1047 -- field for an Id that is part of the current recursive group.
1050 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1051 | otherwise = NoCafRefs
1053 -- used for recursive groups. The whole group is set to
1054 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1055 -- refers to any CAFs.
1057 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1058 | otherwise = NoCafRefs
1060 -- cafRefs compiles to beautiful code :)
1063 | isLocalId id = fastBool False
1065 case lookupVarEnv p id of
1066 Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1067 Just (LetBound _ _ _) -> fastBool False
1068 Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
1070 cafRefs p (Lit l) = fastBool False
1071 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1072 cafRefs p (Lam x e) = cafRefs p e
1073 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1074 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1075 (cafRefss p) (rhssOfAlts alts)
1076 cafRefs p (Note n e) = cafRefs p e
1077 cafRefs p (Type t) = fastBool False
1079 cafRefss p [] = fastBool False
1080 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1082 -- hack for lazy-or over FastBool.
1083 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1085 isCAF :: CoreExpr -> Bool
1086 -- Only called for the RHS of top-level lets
1087 isCAF e = not (rhsIsNonUpd e)
1088 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1091 rhsIsNonUpd :: CoreExpr -> Bool
1092 -- True => Value-lambda, constructor, PAP
1093 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1094 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1096 -- b) (C x xs), where C is a contructors is updatable if the application is
1097 -- dynamic: see isDynConApp
1099 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1101 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
1102 rhsIsNonUpd (Note (SCC _) e) = False
1103 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1104 rhsIsNonUpd other_expr
1105 = go other_expr 0 []
1107 go (Var f) n_args args = idAppIsNonUpd f n_args args
1109 go (App f a) n_args args
1110 | isTypeArg a = go f n_args args
1111 | otherwise = go f (n_args + 1) (a:args)
1113 go (Note (SCC _) f) n_args args = False
1114 go (Note _ f) n_args args = go f n_args args
1116 go other n_args args = False
1118 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1119 idAppIsNonUpd id n_val_args args
1120 | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1121 | otherwise = n_val_args < idArity id
1123 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1124 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1125 -- Top-level constructor applications can usually be allocated
1126 -- statically, but they can't if
1127 -- a) the constructor, or any of the arguments, come from another DLL
1128 -- b) any of the arguments are LitLits
1129 -- (because we can't refer to static labels in other DLLs).
1130 -- If this happens we simply make the RHS into an updatable thunk,
1131 -- and 'exectute' it rather than allocating it statically.
1132 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1135 isDynArg :: CoreExpr -> Bool
1136 isDynArg (Var v) = isDllName (idName v)
1137 isDynArg (Note _ e) = isDynArg e
1138 isDynArg (Lit lit) = isLitLitLit lit
1139 isDynArg (App e _) = isDynArg e -- must be a type app
1140 isDynArg (Lam _ e) = isDynArg e -- must be a type lam