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
161 env' = extendVarEnv env id (LetBound how_bound emptyLVS (predictArity rhs))
163 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
164 | otherwise = TopLevelNoCafs
166 (stg_rhs, fvs', cafs) =
168 coreToStgRhs body_fvs TopLevel (id,rhs)
169 `thenLne` \ (stg_rhs, fvs', _) ->
170 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
171 returnLne (stg_rhs, fvs', cafs)
174 bind = StgNonRec (SRTEntries cafs) id stg_rhs
176 ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id)
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 (predictArity 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(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
212 ASSERT2(consistent caf_info bind, ppr binders)
213 -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
214 (env', fvs' `unionFVInfo` body_fvs, bind)
217 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
222 :: FreeVarsInfo -- Free var info for the scope of the binding
225 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
227 coreToStgRhs scope_fv_info top (binder, rhs)
228 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
229 returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
232 binder_info = lookupFVInfo scope_fv_info binder
234 mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
237 mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
238 = StgRhsClosure noCCS binder_info
243 mkStgRhs top rhs_fvs binder_info (StgConApp con args)
244 | isNotTopLevel top || not (isDllConApp con args)
245 = StgRhsCon noCCS con args
247 mkStgRhs top rhs_fvs binder_info rhs
248 = StgRhsClosure noCCS binder_info
253 updatable args body | null args && isPAP body = ReEntrant
254 | otherwise = Updatable
256 upd = if isOnceDem dem
257 then (if isNotTop toplev
258 then SingleEntry -- HA! Paydirt for "dem"
261 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
265 -- For now we forbid SingleEntry CAFs; they tickle the
266 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
267 -- and I don't understand why. There's only one SE_CAF (well,
268 -- only one that tickled a great gaping bug in an earlier attempt
269 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
270 -- specifically Main.lvl6 in spectral/cryptarithm2.
271 -- So no great loss. KSW 2000-07.
275 Detect thunks which will reduce immediately to PAPs, and make them
276 non-updatable. This has several advantages:
278 - the non-updatable thunk behaves exactly like the PAP,
280 - the thunk is more efficient to enter, because it is
281 specialised to the task.
283 - we save one update frame, one stg_update_PAP, one update
284 and lots of PAP_enters.
286 - in the case where the thunk is top-level, we save building
287 a black hole and futhermore the thunk isn't considered to
288 be a CAF any more, so it doesn't appear in any SRTs.
290 We do it here, because the arity information is accurate, and we need
291 to do it before the SRT pass to save the SRT entries associated with
295 isPAP (StgApp f args) = idArity f > length args
300 -- ---------------------------------------------------------------------------
302 -- ---------------------------------------------------------------------------
307 -> LneM (StgExpr, -- Decorated STG expr
308 FreeVarsInfo, -- Its free vars (NB free, not live)
309 EscVarsSet) -- Its escapees, a subset of its free vars;
310 -- also a subset of the domain of the envt
311 -- because we are only interested in the escapees
312 -- for vars which might be turned into
313 -- let-no-escaped ones.
316 The second and third components can be derived in a simple bottom up pass, not
317 dependent on any decisions about which variables will be let-no-escaped or
318 not. The first component, that is, the decorated expression, may then depend
319 on these components, but it in turn is not scrutinised as the basis for any
320 decisions. Hence no black holes.
323 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
324 coreToStgExpr (Var v) = coreToStgApp Nothing v []
326 coreToStgExpr expr@(App _ _)
327 = coreToStgApp Nothing f args
329 (f, args) = myCollectArgs expr
331 coreToStgExpr expr@(Lam _ _)
332 = let (args, body) = myCollectBinders expr
333 args' = filterStgBinders args
335 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
336 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
338 set_of_args = mkVarSet args'
339 fvs = args' `minusFVBinders` body_fvs
340 escs = body_escs `minusVarSet` set_of_args
341 result_expr | null args' = body
342 | otherwise = StgLam (exprType expr) args' body
344 returnLne (result_expr, fvs, escs)
346 coreToStgExpr (Note (SCC cc) expr)
347 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
348 returnLne (StgSCC cc expr2, fvs, escs) )
350 coreToStgExpr (Note other_note expr)
354 -- Cases require a little more real work.
356 coreToStgExpr (Case scrut bndr alts)
357 = extendVarEnvLne [(bndr, CaseBound)] $
358 vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
359 freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
361 -- determine whether the default binder is dead or not
362 -- This helps the code generator to avoid generating an assignment
363 -- for the case binder (is extremely rare cases) ToDo: remove.
364 bndr'= if (bndr `elementOfFVInfo` alts_fvs)
366 else bndr `setIdOccInfo` IAmDead
368 -- Don't consider the default binder as being 'live in alts',
369 -- since this is from the point of view of the case expr, where
370 -- the default binder is not free.
371 live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
373 -- we tell the scrutinee that everything live in the alts
374 -- is live in it, too.
375 setVarsLiveInCont (live_in_alts,alts_caf_refs) (
376 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
377 freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
378 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
380 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
382 let srt = SRTEntries alts_caf_refs
385 StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
386 bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
387 (alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
388 -- You might think we should have scrut_escs, not
389 -- (getFVSet scrut_fvs), but actually we can't call, and
390 -- then return from, a let-no-escape thing.
393 scrut_ty = idType bndr
394 prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
396 vars_alts (alts,deflt)
398 = mapAndUnzip3Lne vars_prim_alt alts
399 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
401 alts_fvs = unionFVInfos alts_fvs_list
402 alts_escs = unionVarSets alts_escs_list
404 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
406 mkStgPrimAlts scrut_ty alts2 deflt2,
407 alts_fvs `unionFVInfo` deflt_fvs,
408 alts_escs `unionVarSet` deflt_escs
412 = mapAndUnzip3Lne vars_alg_alt alts
413 `thenLne` \ (alts2, alts_fvs_list, alts_escs_list) ->
415 alts_fvs = unionFVInfos alts_fvs_list
416 alts_escs = unionVarSets alts_escs_list
418 vars_deflt deflt `thenLne` \ (deflt2, deflt_fvs, deflt_escs) ->
420 mkStgAlgAlts scrut_ty alts2 deflt2,
421 alts_fvs `unionFVInfo` deflt_fvs,
422 alts_escs `unionVarSet` deflt_escs
426 vars_prim_alt (LitAlt lit, _, rhs)
427 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
428 returnLne ((lit, rhs2), rhs_fvs, rhs_escs)
430 vars_alg_alt (DataAlt con, binders, rhs)
432 -- remove type variables
433 binders' = filterStgBinders binders
435 extendVarEnvLne [(b, CaseBound) | b <- binders'] $
436 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
438 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
439 -- records whether each param is used in the RHS
442 (con, binders', good_use_mask, rhs2),
443 binders' `minusFVBinders` rhs_fvs,
444 rhs_escs `minusVarSet` mkVarSet binders'
445 -- ToDo: remove the minusVarSet;
446 -- since escs won't include any of these binders
448 vars_alg_alt other = pprPanic "vars_alg_alt" (ppr other)
451 = returnLne (StgNoDefault, emptyFVInfo, emptyVarSet)
453 vars_deflt (Just rhs)
454 = coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
455 returnLne (StgBindDefault rhs2, rhs_fvs, rhs_escs)
458 Lets not only take quite a bit of work, but this is where we convert
459 then to let-no-escapes, if we wish.
461 (Meanwhile, we don't expect to see let-no-escapes...)
463 coreToStgExpr (Let bind body)
464 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
465 coreToStgLet no_binder_escapes bind body
466 ) `thenLne` \ (new_let, fvs, escs, _) ->
468 returnLne (new_let, fvs, escs)
471 If we've got a case containing a _ccall_GC_ primop, we need to
472 ensure that the arguments are kept live for the duration of the
473 call. This only an issue
476 isForeignObjArg :: Id -> Bool
477 isForeignObjArg x = isId x && isForeignObjPrimTy (idType x)
479 isForeignObjPrimTy ty
480 = case splitTyConApp_maybe ty of
481 Just (tycon, _) -> tycon == foreignObjPrimTyCon
486 mkStgAlgAlts ty alts deflt
488 -- Get the tycon from the data con
489 (dc, _, _, _) : _rest
490 -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
492 -- Otherwise just do your best
493 [] -> case splitTyConApp_maybe (repType ty) of
494 Just (tc,_) | isAlgTyCon tc
495 -> StgAlgAlts (Just tc) alts deflt
497 -> StgAlgAlts Nothing alts deflt
499 mkStgPrimAlts ty alts deflt
500 = StgPrimAlts (tyConAppTyCon ty) alts deflt
504 -- ---------------------------------------------------------------------------
506 -- ---------------------------------------------------------------------------
510 :: Maybe UpdateFlag -- Just upd <=> this application is
511 -- the rhs of a thunk binding
512 -- x = [...] \upd [] -> the_app
513 -- with specified update flag
515 -> [CoreArg] -- Arguments
516 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
518 coreToStgApp maybe_thunk_body f args
519 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
520 lookupVarLne f `thenLne` \ how_bound ->
524 not_letrec_bound = not (isLetBound how_bound)
525 fun_fvs = singletonFVInfo f how_bound fun_occ
527 f_arity = case how_bound of
528 LetBound _ _ arity -> arity
532 | not_letrec_bound = noBinderInfo -- Uninteresting variable
533 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
534 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
537 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
538 | f_arity == n_args = emptyVarSet -- A function *or thunk* with an exactly
539 -- saturated call doesn't escape
540 -- (let-no-escape applies to 'thunks' too)
542 | otherwise = unitVarSet f -- Inexact application; it does escape
544 -- At the moment of the call:
546 -- either the function is *not* let-no-escaped, in which case
547 -- nothing is live except live_in_cont
548 -- or the function *is* let-no-escaped in which case the
549 -- variables it uses are live, but still the function
550 -- itself is not. PS. In this case, the function's
551 -- live vars should already include those of the
552 -- continuation, but it does no harm to just union the
555 app = case globalIdDetails f of
556 DataConId dc -> StgConApp dc args'
557 PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
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_KeepStgTypes 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
796 (StgLiveVars, IdSet) -- (Live vars, Live CAFs)... see notes below
797 Arity -- its arity (local Ids don't have arity info at this point)
799 isLetBound (LetBound _ _ _) = True
800 isLetBound other = False
803 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
804 variables that are live if x is live. For "normal" variables that is
805 just x alone. If x is a let-no-escaped variable then x is represented
806 by a code pointer and a stack pointer (well, one for each stack). So
807 all of the variables needed in the execution of x are live if x is,
808 and are therefore recorded in the LetBound constructor; x itself
811 The set of live variables is guaranteed ot have no further let-no-escaped
814 The std monad functions:
816 initLne :: IdEnv HowBound -> LneM a -> a
817 initLne env m = m env emptyLVS
819 emptyLVS = (emptyVarSet,emptyVarSet)
821 {-# INLINE thenLne #-}
822 {-# INLINE returnLne #-}
824 returnLne :: a -> LneM a
825 returnLne e env lvs_cont = e
827 thenLne :: LneM a -> (a -> LneM b) -> LneM b
828 thenLne m k env lvs_cont
829 = k (m env lvs_cont) env lvs_cont
831 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
832 mapLne f [] = returnLne []
834 = f x `thenLne` \ r ->
835 mapLne f xs `thenLne` \ rs ->
838 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
840 mapAndUnzipLne f [] = returnLne ([],[])
841 mapAndUnzipLne f (x:xs)
842 = f x `thenLne` \ (r1, r2) ->
843 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
844 returnLne (r1:rs1, r2:rs2)
846 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
848 mapAndUnzip3Lne f [] = returnLne ([],[],[])
849 mapAndUnzip3Lne f (x:xs)
850 = f x `thenLne` \ (r1, r2, r3) ->
851 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
852 returnLne (r1:rs1, r2:rs2, r3:rs3)
854 fixLne :: (a -> LneM a) -> LneM a
855 fixLne expr env lvs_cont
858 result = expr result env lvs_cont
861 Functions specific to this monad:
864 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
865 getVarsLiveInCont env lvs_cont = lvs_cont
867 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
868 setVarsLiveInCont new_lvs_cont expr env lvs_cont
869 = expr env new_lvs_cont
871 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
872 extendVarEnvLne ids_w_howbound expr env lvs_cont
873 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
875 lookupVarLne :: Id -> LneM HowBound
876 lookupVarLne v env lvs_cont
878 case (lookupVarEnv env v) of
880 Nothing -> ImportBound
883 -- The result of lookupLiveVarsForSet, a set of live variables, is
884 -- only ever tacked onto a decorated expression. It is never used as
885 -- the basis of a control decision, which might give a black hole.
887 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
888 freeVarsToLiveVars fvs env live_in_cont
889 = returnLne (lvs, cafs) env live_in_cont
891 (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
892 (local, global) = partition isLocalId (allFVs fvs)
894 (lvs_from_fvs, caf_extras) = unzip (map do_one local)
896 lvs = unionVarSets lvs_from_fvs
897 `unionVarSet` lvs_cont
899 cafs = mkVarSet (filter is_caf_one global)
900 `unionVarSet` (unionVarSets caf_extras)
901 `unionVarSet` cafs_cont
904 = case (lookupVarEnv env v) of
905 Just (LetBound _ (lvs,cafs) _) -> (extendVarSet lvs v, cafs)
906 Just _ -> (unitVarSet v, emptyVarSet)
907 Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
910 = case lookupVarEnv env v of
911 Just (LetBound TopLevelHasCafs (lvs,_) _) ->
912 ASSERT( isEmptyVarSet lvs ) True
913 Just (LetBound _ _ _) -> False
914 _otherwise -> mayHaveCafRefs (idCafInfo v)
917 %************************************************************************
919 \subsection[Free-var info]{Free variable information}
921 %************************************************************************
924 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
925 -- If f is mapped to noBinderInfo, that means
926 -- that f *is* mentioned (else it wouldn't be in the
927 -- IdEnv at all), but perhaps in an unsaturated applications.
929 -- All case/lambda-bound things are also mapped to
930 -- noBinderInfo, since we aren't interested in their
933 -- For ILX we track free var info for type variables too;
934 -- hence VarEnv not IdEnv
942 type EscVarsSet = IdSet
946 emptyFVInfo :: FreeVarsInfo
947 emptyFVInfo = emptyVarEnv
949 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
950 singletonFVInfo id ImportBound info
951 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
952 | otherwise = emptyVarEnv
953 singletonFVInfo id (LetBound top_level _ _) info
954 = unitVarEnv id (id, top_level, info)
955 singletonFVInfo id other info
956 = unitVarEnv id (id, NotTopLevelBound, info)
958 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
959 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
961 add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
963 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
964 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
966 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
967 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
969 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
970 minusFVBinders vs fv = foldr minusFVBinder fv vs
972 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
973 minusFVBinder v fv | isId v && opt_KeepStgTypes
974 = (fv `delVarEnv` v) `unionFVInfo`
975 tyvarFVInfo (tyVarsOfType (idType v))
976 | otherwise = fv `delVarEnv` v
977 -- When removing a binder, remember to add its type variables
978 -- c.f. CoreFVs.delBinderFV
980 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
981 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
983 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
984 -- Find how the given Id is used.
985 -- Externally visible things may be used any old how
987 | isExternallyVisibleName (idName id) = noBinderInfo
988 | otherwise = case lookupVarEnv fvs id of
989 Nothing -> noBinderInfo
990 Just (_,_,info) -> info
992 allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
993 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
995 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
996 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
998 getFVSet :: FreeVarsInfo -> IdSet
999 getFVSet fvs = mkVarSet (getFVs fvs)
1001 plusFVInfo (id1,top1,info1) (id2,top2,info2)
1002 = ASSERT (id1 == id2 && top1 == top2)
1003 (id1, top1, combineStgBinderInfo info1 info2)
1008 filterStgBinders :: [Var] -> [Var]
1009 filterStgBinders bndrs
1010 | opt_KeepStgTypes = bndrs
1011 | otherwise = filter isId bndrs
1016 -- Ignore all notes except SCC
1017 myCollectBinders expr
1020 go bs (Lam b e) = go (b:bs) e
1021 go bs e@(Note (SCC _) _) = (reverse bs, e)
1022 go bs (Note _ e) = go bs e
1023 go bs e = (reverse bs, e)
1025 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1026 -- We assume that we only have variables
1027 -- in the function position by now
1031 go (Var v) as = (v, as)
1032 go (App f a) as = go f (a:as)
1033 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1034 go (Note n e) as = go e as
1035 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1038 %************************************************************************
1040 \subsection{Figuring out CafInfo for an expression}
1042 %************************************************************************
1044 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1045 We mark such things as `MayHaveCafRefs' because this information is
1046 used to decide whether a particular closure needs to be referenced
1049 There are two reasons for setting MayHaveCafRefs:
1050 a) The RHS is a CAF: a top-level updatable thunk.
1051 b) The RHS refers to something that MayHaveCafRefs
1053 Possible improvement: In an effort to keep the number of CAFs (and
1054 hence the size of the SRTs) down, we could also look at the expression and
1055 decide whether it requires a small bounded amount of heap, so we can ignore
1056 it as a CAF. In these cases however, we would need to use an additional
1057 CAF list to keep track of non-collectable CAFs.
1060 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1061 -- Only called for the RHS of top-level lets
1062 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1063 -- predicate returns True for a given Id if we look at this Id when
1064 -- calculating the result. Used to *avoid* looking at the CafInfo
1065 -- field for an Id that is part of the current recursive group.
1068 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1069 | otherwise = NoCafRefs
1071 -- used for recursive groups. The whole group is set to
1072 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1073 -- refers to any CAFs.
1075 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1076 | otherwise = NoCafRefs
1078 -- cafRefs compiles to beautiful code :)
1081 | isLocalId id = fastBool False
1083 case lookupVarEnv p id of
1084 Just (LetBound TopLevelHasCafs _ _) -> fastBool True
1085 Just (LetBound _ _ _) -> fastBool False
1086 Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
1088 cafRefs p (Lit l) = fastBool False
1089 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1090 cafRefs p (Lam x e) = cafRefs p e
1091 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1092 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1093 (cafRefss p) (rhssOfAlts alts)
1094 cafRefs p (Note n e) = cafRefs p e
1095 cafRefs p (Type t) = fastBool False
1097 cafRefss p [] = fastBool False
1098 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1100 -- hack for lazy-or over FastBool.
1101 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1103 isCAF :: CoreExpr -> Bool
1104 -- Only called for the RHS of top-level lets
1105 isCAF e = not (rhsIsNonUpd e)
1106 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1109 rhsIsNonUpd :: CoreExpr -> Bool
1110 -- True => Value-lambda, constructor, PAP
1111 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1112 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1114 -- b) (C x xs), where C is a contructors is updatable if the application is
1115 -- dynamic: see isDynConApp
1117 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1119 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
1120 rhsIsNonUpd (Note (SCC _) e) = False
1121 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1122 rhsIsNonUpd other_expr
1123 = go other_expr 0 []
1125 go (Var f) n_args args = idAppIsNonUpd f n_args args
1127 go (App f a) n_args args
1128 | isTypeArg a = go f n_args args
1129 | otherwise = go f (n_args + 1) (a:args)
1131 go (Note (SCC _) f) n_args args = False
1132 go (Note _ f) n_args args = go f n_args args
1134 go other n_args args = False
1136 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1137 idAppIsNonUpd id n_val_args args
1138 | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1139 | otherwise = n_val_args < idArity id
1141 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1142 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1143 -- Top-level constructor applications can usually be allocated
1144 -- statically, but they can't if
1145 -- a) the constructor, or any of the arguments, come from another DLL
1146 -- b) any of the arguments are LitLits
1147 -- (because we can't refer to static labels in other DLLs).
1148 -- If this happens we simply make the RHS into an updatable thunk,
1149 -- and 'exectute' it rather than allocating it statically.
1150 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1153 isDynArg :: CoreExpr -> Bool
1154 isDynArg (Var v) = isDllName (idName v)
1155 isDynArg (Note _ e) = isDynArg e
1156 isDynArg (Lit lit) = isLitLitLit lit
1157 isDynArg (App e _) = isDynArg e -- must be a type app
1158 isDynArg (Lam _ e) = isDynArg e -- must be a type lam