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 )
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
161 env' = extendVarEnv env id (LetBound how_bound emptyVarSet)
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(consistent caf_info bind, ppr id)
177 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
178 (env', fvs' `unionFVInfo` body_fvs, bind)
180 coreTopBindToStg env body_fvs (Rec pairs)
182 (binders, rhss) = unzip pairs
184 -- to calculate caf_info, we initially map all the binders to
186 env1 = extendVarEnvList env
187 [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ]
189 caf_info = hasCafRefss env1{-NB: not env'-} rhss
191 env' = extendVarEnvList env
192 [ (b, LetBound how_bound emptyVarSet) | b <- binders ]
194 how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
195 | otherwise = TopLevelNoCafs
197 (stg_rhss, fvs', cafs)
199 mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
200 `thenLne` \ (stg_rhss, fvss', _) ->
201 let fvs' = unionFVInfos fvss' in
202 freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
203 returnLne (stg_rhss, fvs', cafs)
206 bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
208 ASSERT2(consistent caf_info bind, ppr binders)
209 -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
210 (env', fvs' `unionFVInfo` body_fvs, bind)
213 consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
218 :: FreeVarsInfo -- Free var info for the scope of the binding
221 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
223 coreToStgRhs scope_fv_info top (binder, rhs)
224 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
225 returnLne (mkStgRhs top rhs_fvs binder_info new_rhs,
228 binder_info = lookupFVInfo scope_fv_info binder
230 bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr
231 bogus_expr = (StgLit (MachInt 1))
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_info = idArityInfo f
533 f_arity = arityLowerBound f_arity_info -- Zero if no info
536 | not_letrec_bound = noBinderInfo -- Uninteresting variable
537 | f_arity > 0 && f_arity <= n_args = stgSatOcc -- Saturated or over-saturated function call
538 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
541 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
542 | hasArity f_arity_info &&
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
628 else (emptyVarSet,emptyVarSet))
629 (vars_bind rec_body_fvs bind)
630 `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) ->
633 extendVarEnvLne env_ext (
634 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
635 freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
637 returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
638 body2, body_fvs, body_escs, body_lvs)
641 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
642 body2, body_fvs, body_escs, body_lvs) ->
645 -- Compute the new let-expression
647 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
648 | otherwise = StgLet bind2 body2
651 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
654 = bind_lvs `unionVarSet` (body_lvs `minusVarSet` set_of_binders)
656 real_bind_escs = if let_no_escape then
660 -- Everything escapes which is free in the bindings
662 let_escs = (real_bind_escs `unionVarSet` body_escs) `minusVarSet` set_of_binders
664 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
667 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
670 -- Debugging code as requested by Andrew Kennedy
671 checked_no_binder_escapes
672 | not no_binder_escapes && any is_join_var binders
673 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
675 | otherwise = no_binder_escapes
677 checked_no_binder_escapes = no_binder_escapes
680 -- Mustn't depend on the passed-in let_no_escape flag, since
681 -- no_binder_escapes is used by the caller to derive the flag!
687 checked_no_binder_escapes
690 set_of_binders = mkVarSet binders
691 binders = case bind of
692 NonRec binder rhs -> [binder]
693 Rec pairs -> map fst pairs
695 mk_binding bind_lvs binder
696 = (binder, LetBound NotTopLevelBound -- Not top level
700 live_vars = if let_no_escape then
701 extendVarSet bind_lvs binder
705 vars_bind :: FreeVarsInfo -- Free var info for body of binding
709 EscVarsSet, -- free vars; escapee vars
710 StgLiveVars, -- vars live in binding
711 [(Id, HowBound)]) -- extension to environment
714 vars_bind body_fvs (NonRec binder rhs)
715 = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
716 `thenLne` \ (rhs2, bind_fvs, escs) ->
718 freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
720 env_ext_item@(binder', _) = mk_binding bind_lvs binder
722 returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
723 bind_fvs, escs, bind_lvs, [env_ext_item])
726 vars_bind body_fvs (Rec pairs)
727 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, _) ->
729 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
730 binders = map fst pairs
731 env_ext = map (mk_binding bind_lvs) binders
733 extendVarEnvLne env_ext (
734 mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
735 `thenLne` \ (rhss2, fvss, escss) ->
737 bind_fvs = unionFVInfos fvss
738 escs = unionVarSets escss
740 freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
741 `thenLne` \ (bind_lvs, bind_cafs) ->
742 returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
743 bind_fvs, escs, bind_lvs, env_ext)
747 is_join_var :: Id -> Bool
748 -- A hack (used only for compiler debuggging) to tell if
749 -- a variable started life as a join point ($j)
750 is_join_var j = occNameUserString (getOccName j) == "$j"
753 %************************************************************************
755 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
757 %************************************************************************
759 There's a lot of stuff to pass around, so we use this @LneM@ monad to
760 help. All the stuff here is only passed *down*.
763 type LneM a = IdEnv HowBound
764 -> (StgLiveVars, -- vars live in continuation
765 IdSet) -- cafs live in continuation
774 StgLiveVars -- Live vars... see notes below
776 isLetBound (LetBound _ _) = True
777 isLetBound other = False
780 For a let(rec)-bound variable, x, we record StgLiveVars, the set of
781 variables that are live if x is live. For "normal" variables that is
782 just x alone. If x is a let-no-escaped variable then x is represented
783 by a code pointer and a stack pointer (well, one for each stack). So
784 all of the variables needed in the execution of x are live if x is,
785 and are therefore recorded in the LetBound constructor; x itself
788 The set of live variables is guaranteed ot have no further let-no-escaped
791 The std monad functions:
793 initLne :: IdEnv HowBound -> LneM a -> a
794 initLne env m = m env (emptyVarSet,emptyVarSet)
796 {-# INLINE thenLne #-}
797 {-# INLINE returnLne #-}
799 returnLne :: a -> LneM a
800 returnLne e env lvs_cont = e
802 thenLne :: LneM a -> (a -> LneM b) -> LneM b
803 thenLne m k env lvs_cont
804 = k (m env lvs_cont) env lvs_cont
806 mapLne :: (a -> LneM b) -> [a] -> LneM [b]
807 mapLne f [] = returnLne []
809 = f x `thenLne` \ r ->
810 mapLne f xs `thenLne` \ rs ->
813 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
815 mapAndUnzipLne f [] = returnLne ([],[])
816 mapAndUnzipLne f (x:xs)
817 = f x `thenLne` \ (r1, r2) ->
818 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
819 returnLne (r1:rs1, r2:rs2)
821 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
823 mapAndUnzip3Lne f [] = returnLne ([],[],[])
824 mapAndUnzip3Lne f (x:xs)
825 = f x `thenLne` \ (r1, r2, r3) ->
826 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
827 returnLne (r1:rs1, r2:rs2, r3:rs3)
829 fixLne :: (a -> LneM a) -> LneM a
830 fixLne expr env lvs_cont
833 result = expr result env lvs_cont
836 Functions specific to this monad:
839 getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
840 getVarsLiveInCont env lvs_cont = lvs_cont
842 setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
843 setVarsLiveInCont new_lvs_cont expr env lvs_cont
844 = expr env new_lvs_cont
846 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
847 extendVarEnvLne ids_w_howbound expr env lvs_cont
848 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
850 lookupVarLne :: Id -> LneM HowBound
851 lookupVarLne v env lvs_cont
853 case (lookupVarEnv env v) of
855 Nothing -> ImportBound
858 -- The result of lookupLiveVarsForSet, a set of live variables, is
859 -- only ever tacked onto a decorated expression. It is never used as
860 -- the basis of a control decision, which might give a black hole.
862 freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
863 freeVarsToLiveVars fvs env live_in_cont
864 = returnLne (lvs `unionVarSet` lvs_cont,
865 mkVarSet cafs `unionVarSet` cafs_cont)
868 (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
869 (local, global) = partition isLocalId (allFVs fvs)
871 cafs = filter is_caf_one global
872 lvs = unionVarSets (map do_one local)
875 = if isLocalId v then
876 case (lookupVarEnv env v) of
877 Just (LetBound _ lvs) -> extendVarSet lvs v
878 Just _ -> unitVarSet v
879 Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
884 = case lookupVarEnv env v of
885 Just (LetBound TopLevelHasCafs lvs) ->
886 ASSERT( isEmptyVarSet lvs ) True
887 Just (LetBound _ _) -> False
888 _otherwise -> mayHaveCafRefs (idCafInfo v)
891 %************************************************************************
893 \subsection[Free-var info]{Free variable information}
895 %************************************************************************
898 type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
899 -- If f is mapped to noBinderInfo, that means
900 -- that f *is* mentioned (else it wouldn't be in the
901 -- IdEnv at all), but perhaps in an unsaturated applications.
903 -- All case/lambda-bound things are also mapped to
904 -- noBinderInfo, since we aren't interested in their
907 -- For ILX we track free var info for type variables too;
908 -- hence VarEnv not IdEnv
916 type EscVarsSet = IdSet
920 emptyFVInfo :: FreeVarsInfo
921 emptyFVInfo = emptyVarEnv
923 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
924 singletonFVInfo id ImportBound info
925 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
926 | otherwise = emptyVarEnv
927 singletonFVInfo id (LetBound top_level _) info
928 = unitVarEnv id (id, top_level, info)
929 singletonFVInfo id other info
930 = unitVarEnv id (id, NotTopLevelBound, info)
932 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
933 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
935 add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
937 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
938 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
940 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
941 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
943 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
944 minusFVBinders vs fv = foldr minusFVBinder fv vs
946 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
947 minusFVBinder v fv | isId v && opt_KeepStgTypes
948 = (fv `delVarEnv` v) `unionFVInfo`
949 tyvarFVInfo (tyVarsOfType (idType v))
950 | otherwise = fv `delVarEnv` v
951 -- When removing a binder, remember to add its type variables
952 -- c.f. CoreFVs.delBinderFV
954 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
955 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
957 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
958 -- Find how the given Id is used.
959 -- Externally visible things may be used any old how
961 | isExternallyVisibleName (idName id) = noBinderInfo
962 | otherwise = case lookupVarEnv fvs id of
963 Nothing -> noBinderInfo
964 Just (_,_,info) -> info
966 allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
967 allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
969 getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
970 getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
972 getFVSet :: FreeVarsInfo -> IdSet
973 getFVSet fvs = mkVarSet (getFVs fvs)
975 plusFVInfo (id1,top1,info1) (id2,top2,info2)
976 = ASSERT (id1 == id2 && top1 == top2)
977 (id1, top1, combineStgBinderInfo info1 info2)
982 filterStgBinders :: [Var] -> [Var]
983 filterStgBinders bndrs
984 | opt_KeepStgTypes = bndrs
985 | otherwise = filter isId bndrs
990 -- Ignore all notes except SCC
991 myCollectBinders expr
994 go bs (Lam b e) = go (b:bs) e
995 go bs e@(Note (SCC _) _) = (reverse bs, e)
996 go bs (Note _ e) = go bs e
997 go bs e = (reverse bs, e)
999 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1000 -- We assume that we only have variables
1001 -- in the function position by now
1005 go (Var v) as = (v, as)
1006 go (App f a) as = go f (a:as)
1007 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1008 go (Note n e) as = go e as
1009 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1012 %************************************************************************
1014 \subsection{Figuring out CafInfo for an expression}
1016 %************************************************************************
1018 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
1019 We mark such things as `MayHaveCafRefs' because this information is
1020 used to decide whether a particular closure needs to be referenced
1023 There are two reasons for setting MayHaveCafRefs:
1024 a) The RHS is a CAF: a top-level updatable thunk.
1025 b) The RHS refers to something that MayHaveCafRefs
1027 Possible improvement: In an effort to keep the number of CAFs (and
1028 hence the size of the SRTs) down, we could also look at the expression and
1029 decide whether it requires a small bounded amount of heap, so we can ignore
1030 it as a CAF. In these cases however, we would need to use an additional
1031 CAF list to keep track of non-collectable CAFs.
1034 hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo
1035 -- Only called for the RHS of top-level lets
1036 hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
1037 -- predicate returns True for a given Id if we look at this Id when
1038 -- calculating the result. Used to *avoid* looking at the CafInfo
1039 -- field for an Id that is part of the current recursive group.
1042 | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
1043 | otherwise = NoCafRefs
1045 -- used for recursive groups. The whole group is set to
1046 -- "MayHaveCafRefs" if at least one of the group is a CAF or
1047 -- refers to any CAFs.
1049 | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
1050 | otherwise = NoCafRefs
1052 -- cafRefs compiles to beautiful code :)
1055 | isLocalId id = fastBool False
1057 case lookupVarEnv p id of
1058 Just (LetBound TopLevelHasCafs _) -> fastBool True
1059 Just (LetBound _ _) -> fastBool False
1060 Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
1062 cafRefs p (Lit l) = fastBool False
1063 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
1064 cafRefs p (Lam x e) = cafRefs p e
1065 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
1066 cafRefs p (Case e bndr alts) = fastOr (cafRefs p e)
1067 (cafRefss p) (rhssOfAlts alts)
1068 cafRefs p (Note n e) = cafRefs p e
1069 cafRefs p (Type t) = fastBool False
1071 cafRefss p [] = fastBool False
1072 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
1074 -- hack for lazy-or over FastBool.
1075 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))
1077 isCAF :: CoreExpr -> Bool
1078 -- Only called for the RHS of top-level lets
1079 isCAF e = not (rhsIsNonUpd e)
1080 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
1083 rhsIsNonUpd :: CoreExpr -> Bool
1084 -- True => Value-lambda, constructor, PAP
1085 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1086 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1088 -- b) (C x xs), where C is a contructors is updatable if the application is
1089 -- dynamic: see isDynConApp
1091 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
1093 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
1094 rhsIsNonUpd (Note (SCC _) e) = False
1095 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
1096 rhsIsNonUpd other_expr
1097 = go other_expr 0 []
1099 go (Var f) n_args args = idAppIsNonUpd f n_args args
1101 go (App f a) n_args args
1102 | isTypeArg a = go f n_args args
1103 | otherwise = go f (n_args + 1) (a:args)
1105 go (Note (SCC _) f) n_args args = False
1106 go (Note _ f) n_args args = go f n_args args
1108 go other n_args args = False
1110 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1111 idAppIsNonUpd id n_val_args args
1112 | Just con <- isDataConId_maybe id = not (isDynConApp con args)
1113 | otherwise = n_val_args < idArity id
1115 isDynConApp :: DataCon -> [CoreExpr] -> Bool
1116 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
1117 -- Top-level constructor applications can usually be allocated
1118 -- statically, but they can't if
1119 -- a) the constructor, or any of the arguments, come from another DLL
1120 -- b) any of the arguments are LitLits
1121 -- (because we can't refer to static labels in other DLLs).
1122 -- If this happens we simply make the RHS into an updatable thunk,
1123 -- and 'exectute' it rather than allocating it statically.
1124 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
1127 isDynArg :: CoreExpr -> Bool
1128 isDynArg (Var v) = isDllName (idName v)
1129 isDynArg (Note _ e) = isDynArg e
1130 isDynArg (Lit lit) = isLitLitLit lit
1131 isDynArg (App e _) = isDynArg e -- must be a type app
1132 isDynArg (Lam _ e) = isDynArg e -- must be a type lam