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
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 module CoreToStg ( coreToStg, coreExprToStg ) where
19 #include "HsVersions.h"
22 import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
28 import Var ( Var, globalIdDetails, idType )
31 import CostCentre ( noCCS )
34 import Maybes ( maybeToBool )
35 import Name ( getOccName, isExternalName, nameOccName )
36 import OccName ( occNameString, occNameFS )
37 import BasicTypes ( Arity )
38 import StaticFlags ( opt_RuntimeTypes )
45 %************************************************************************
47 \subsection[live-vs-free-doc]{Documentation}
49 %************************************************************************
51 (There is other relevant documentation in codeGen/CgLetNoEscape.)
53 The actual Stg datatype is decorated with {\em live variable}
54 information, as well as {\em free variable} information. The two are
55 {\em not} the same. Liveness is an operational property rather than a
56 semantic one. A variable is live at a particular execution point if
57 it can be referred to {\em directly} again. In particular, a dead
58 variable's stack slot (if it has one):
61 should be stubbed to avoid space leaks, and
63 may be reused for something else.
66 There ought to be a better way to say this. Here are some examples:
73 Just after the `in', v is live, but q is dead. If the whole of that
74 let expression was enclosed in a case expression, thus:
76 case (let v = [q] \[x] -> e in ...v...) of
79 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
80 we'll return later to the @alts@ and need it.
82 Let-no-escapes make this a bit more interesting:
84 let-no-escape v = [q] \ [x] -> e
88 Here, @q@ is still live at the `in', because @v@ is represented not by
89 a closure but by the current stack state. In other words, if @v@ is
90 live then so is @q@. Furthermore, if @e@ mentions an enclosing
91 let-no-escaped variable, then {\em its} free variables are also live
94 %************************************************************************
96 \subsection[caf-info]{Collecting live CAF info}
98 %************************************************************************
100 In this pass we also collect information on which CAFs are live for
101 constructing SRTs (see SRT.lhs).
103 A top-level Id has CafInfo, which is
105 - MayHaveCafRefs, if it may refer indirectly to
107 - NoCafRefs if it definitely doesn't
109 The CafInfo has already been calculated during the CoreTidy pass.
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)
121 Interaction of let-no-escape with SRTs [Sept 01]
122 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
125 let-no-escape x = ...caf1...caf2...
129 where caf1,caf2 are CAFs. Since x doesn't have a closure, we
130 build SRTs just as if x's defn was inlined at each call site, and
131 that means that x's CAF refs get duplicated in the overall SRT.
133 This is unlike ordinary lets, in which the CAF refs are not duplicated.
135 We could fix this loss of (static) sharing by making a sort of pseudo-closure
136 for x, solely to put in the SRTs lower down.
139 %************************************************************************
141 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
143 %************************************************************************
146 coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
147 coreToStg this_pkg pgm
149 where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
151 coreExprToStg :: CoreExpr -> StgExpr
153 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
158 -> IdEnv HowBound -- environment for the bindings
160 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
162 coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
163 coreTopBindsToStg this_pkg env (b:bs)
164 = (env2, fvs2, b':bs')
166 -- env accumulates down the list of binds, fvs accumulates upwards
167 (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
168 (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
174 -> FreeVarsInfo -- Info about the body
176 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
178 coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
180 env' = extendVarEnv env id how_bound
181 how_bound = LetBound TopLet $! manifestArity rhs
185 coreToTopStgRhs this_pkg body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
186 returnLne (stg_rhs, fvs')
189 bind = StgNonRec id stg_rhs
191 ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id $$ (ptext SLIT("rhs:")) <+> ppr rhs $$ (ptext SLIT("stg_rhs:"))<+> ppr stg_rhs $$ (ptext SLIT("Manifest:")) <+> (ppr $ manifestArity rhs) $$ (ptext SLIT("STG:")) <+>(ppr $ stgRhsArity stg_rhs) )
192 ASSERT2(consistentCafInfo id bind, ppr id)
193 -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
194 (env', fvs' `unionFVInfo` body_fvs, bind)
196 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
198 (binders, rhss) = unzip pairs
200 extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
201 | (b, rhs) <- pairs ]
202 env' = extendVarEnvList env extra_env'
206 mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
207 `thenLne` \ (stg_rhss, fvss') ->
208 let fvs' = unionFVInfos fvss' in
209 returnLne (stg_rhss, fvs')
212 bind = StgRec (zip binders stg_rhss)
214 ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
215 ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
216 (env', fvs' `unionFVInfo` body_fvs, bind)
218 -- Assertion helper: this checks that the CafInfo on the Id matches
219 -- what CoreToStg has figured out about the binding's SRT. The
220 -- CafInfo will be exact in all cases except when CorePrep has
221 -- floated out a binding, in which case it will be approximate.
222 consistentCafInfo id bind
223 | occNameFS (nameOccName (idName id)) == FSLIT("sat")
226 = WARN (not exact, ppr id) safe
228 safe = id_marked_caffy || not binding_is_caffy
229 exact = id_marked_caffy == binding_is_caffy
230 id_marked_caffy = mayHaveCafRefs (idCafInfo id)
231 binding_is_caffy = stgBindHasCafRefs bind
237 -> FreeVarsInfo -- Free var info for the scope of the binding
239 -> LneM (StgRhs, FreeVarsInfo)
241 coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
242 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
243 freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
244 returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
246 bndr_info = lookupFVInfo scope_fv_info bndr
247 is_static = rhsIsStatic this_pkg rhs
249 mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
252 mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
253 = ASSERT( is_static )
254 StgRhsClosure noCCS binder_info
260 mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
261 | is_static -- StgConApps can be updatable (see isCrossDllConApp)
262 = StgRhsCon noCCS con args
264 mkTopStgRhs is_static rhs_fvs srt binder_info rhs
265 = ASSERT2( not is_static, ppr rhs )
266 StgRhsClosure noCCS binder_info
274 -- ---------------------------------------------------------------------------
276 -- ---------------------------------------------------------------------------
281 -> LneM (StgExpr, -- Decorated STG expr
282 FreeVarsInfo, -- Its free vars (NB free, not live)
283 EscVarsSet) -- Its escapees, a subset of its free vars;
284 -- also a subset of the domain of the envt
285 -- because we are only interested in the escapees
286 -- for vars which might be turned into
287 -- let-no-escaped ones.
290 The second and third components can be derived in a simple bottom up pass, not
291 dependent on any decisions about which variables will be let-no-escaped or
292 not. The first component, that is, the decorated expression, may then depend
293 on these components, but it in turn is not scrutinised as the basis for any
294 decisions. Hence no black holes.
297 coreToStgExpr (Lit l) = returnLne (StgLit l, emptyFVInfo, emptyVarSet)
298 coreToStgExpr (Var v) = coreToStgApp Nothing v []
300 coreToStgExpr expr@(App _ _)
301 = coreToStgApp Nothing f args
303 (f, args) = myCollectArgs expr
305 coreToStgExpr expr@(Lam _ _)
307 (args, body) = myCollectBinders expr
308 args' = filterStgBinders args
310 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $
311 coreToStgExpr body `thenLne` \ (body, body_fvs, body_escs) ->
313 fvs = args' `minusFVBinders` body_fvs
314 escs = body_escs `delVarSetList` args'
315 result_expr | null args' = body
316 | otherwise = StgLam (exprType expr) args' body
318 returnLne (result_expr, fvs, escs)
320 coreToStgExpr (Note (SCC cc) expr)
321 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
322 returnLne (StgSCC cc expr2, fvs, escs) )
324 coreToStgExpr (Case (Var id) _bndr ty [(DEFAULT,[],expr)])
325 | Just (TickBox m n) <- isTickBoxOp_maybe id
326 = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
327 returnLne (StgTick m n expr2, fvs, escs) )
329 coreToStgExpr (Note other_note expr)
332 coreToStgExpr (Cast expr co)
335 -- Cases require a little more real work.
337 coreToStgExpr (Case scrut bndr _ alts)
338 = extendVarEnvLne [(bndr, LambdaBound)] (
339 mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) ->
342 unionVarSets escs_s )
343 ) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
345 -- Determine whether the default binder is dead or not
346 -- This helps the code generator to avoid generating an assignment
347 -- for the case binder (is extremely rare cases) ToDo: remove.
348 bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
349 | otherwise = bndr `setIdOccInfo` IAmDead
351 -- Don't consider the default binder as being 'live in alts',
352 -- since this is from the point of view of the case expr, where
353 -- the default binder is not free.
354 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
355 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
358 freeVarsToLiveVars alts_fvs_wo_bndr `thenLne` \ alts_lv_info ->
360 -- We tell the scrutinee that everything
361 -- live in the alts is live in it, too.
362 setVarsLiveInCont alts_lv_info (
363 coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
364 freeVarsToLiveVars scrut_fvs `thenLne` \ scrut_lv_info ->
365 returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
367 `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lv_info) ->
370 StgCase scrut2 (getLiveVars scrut_lv_info)
371 (getLiveVars alts_lv_info)
374 (mkStgAltType bndr alts)
376 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
377 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
378 -- You might think we should have scrut_escs, not
379 -- (getFVSet scrut_fvs), but actually we can't call, and
380 -- then return from, a let-no-escape thing.
383 vars_alt (con, binders, rhs)
384 = let -- Remove type variables
385 binders' = filterStgBinders binders
387 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $
388 coreToStgExpr rhs `thenLne` \ (rhs2, rhs_fvs, rhs_escs) ->
390 -- Records whether each param is used in the RHS
391 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
393 returnLne ( (con, binders', good_use_mask, rhs2),
394 binders' `minusFVBinders` rhs_fvs,
395 rhs_escs `delVarSetList` binders' )
396 -- ToDo: remove the delVarSet;
397 -- since escs won't include any of these binders
400 Lets not only take quite a bit of work, but this is where we convert
401 then to let-no-escapes, if we wish.
403 (Meanwhile, we don't expect to see let-no-escapes...)
405 coreToStgExpr (Let bind body)
406 = fixLne (\ ~(_, _, _, no_binder_escapes) ->
407 coreToStgLet no_binder_escapes bind body
408 ) `thenLne` \ (new_let, fvs, escs, _) ->
410 returnLne (new_let, fvs, escs)
414 mkStgAltType bndr alts
415 = case splitTyConApp_maybe (repType (idType bndr)) of
416 Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
417 | isUnLiftedTyCon tc -> PrimAlt tc
418 | isHiBootTyCon tc -> look_for_better_tycon
419 | isAlgTyCon tc -> AlgAlt tc
420 | otherwise -> ASSERT( _is_poly_alt_tycon tc )
425 _is_poly_alt_tycon tc
427 || isPrimTyCon tc -- "Any" is lifted but primitive
428 || isOpenTyCon tc -- Type family; e.g. arising from strict
429 -- function application where argument has a
432 -- Sometimes, the TyCon is a HiBootTyCon which may not have any
433 -- constructors inside it. Then we can get a better TyCon by
434 -- grabbing the one from a constructor alternative
436 look_for_better_tycon
437 | ((DataAlt con, _, _) : _) <- data_alts =
438 AlgAlt (dataConTyCon con)
440 ASSERT(null data_alts)
443 (data_alts, _deflt) = findDefault alts
447 -- ---------------------------------------------------------------------------
449 -- ---------------------------------------------------------------------------
453 :: Maybe UpdateFlag -- Just upd <=> this application is
454 -- the rhs of a thunk binding
455 -- x = [...] \upd [] -> the_app
456 -- with specified update flag
458 -> [CoreArg] -- Arguments
459 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
462 coreToStgApp maybe_thunk_body f args
463 = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
464 lookupVarLne f `thenLne` \ how_bound ->
467 n_val_args = valArgCount args
468 not_letrec_bound = not (isLetBound how_bound)
470 = let fvs = singletonFVInfo f how_bound fun_occ in
471 -- e.g. (f :: a -> int) (x :: a)
472 -- Here the free variables are "f", "x" AND the type variable "a"
473 -- coreToStgArgs will deal with the arguments recursively
474 if opt_RuntimeTypes then
475 fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f))
478 -- Mostly, the arity info of a function is in the fn's IdInfo
479 -- But new bindings introduced by CoreSat may not have no
480 -- arity info; it would do us no good anyway. For example:
481 -- let f = \ab -> e in f
482 -- No point in having correct arity info for f!
483 -- Hence the hasArity stuff below.
484 -- NB: f_arity is only consulted for LetBound things
485 f_arity = stgArity f how_bound
486 saturated = f_arity <= n_val_args
489 | not_letrec_bound = noBinderInfo -- Uninteresting variable
490 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
491 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
494 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
495 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
496 -- saturated call doesn't escape
497 -- (let-no-escape applies to 'thunks' too)
499 | otherwise = unitVarSet f -- Inexact application; it does escape
501 -- At the moment of the call:
503 -- either the function is *not* let-no-escaped, in which case
504 -- nothing is live except live_in_cont
505 -- or the function *is* let-no-escaped in which case the
506 -- variables it uses are live, but still the function
507 -- itself is not. PS. In this case, the function's
508 -- live vars should already include those of the
509 -- continuation, but it does no harm to just union the
512 res_ty = exprType (mkApps (Var f) args)
513 app = case globalIdDetails f of
514 DataConWorkId dc | saturated -> StgConApp dc args'
515 PrimOpId op -> ASSERT( saturated )
516 StgOpApp (StgPrimOp op) args' res_ty
517 FCallId call -> ASSERT( saturated )
518 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
519 TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
520 _other -> StgApp f args'
525 fun_fvs `unionFVInfo` args_fvs,
526 fun_escs `unionVarSet` (getFVSet args_fvs)
527 -- All the free vars of the args are disqualified
528 -- from being let-no-escaped.
533 -- ---------------------------------------------------------------------------
535 -- This is the guy that turns applications into A-normal form
536 -- ---------------------------------------------------------------------------
538 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
540 = returnLne ([], emptyFVInfo)
542 coreToStgArgs (Type ty : args) -- Type argument
543 = coreToStgArgs args `thenLne` \ (args', fvs) ->
544 if opt_RuntimeTypes then
545 returnLne (StgTypeArg ty : args', fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType ty))
547 returnLne (args', fvs)
549 coreToStgArgs (arg : args) -- Non-type argument
550 = coreToStgArgs args `thenLne` \ (stg_args, args_fvs) ->
551 coreToStgExpr arg `thenLne` \ (arg', arg_fvs, escs) ->
553 fvs = args_fvs `unionFVInfo` arg_fvs
554 stg_arg = case arg' of
555 StgApp v [] -> StgVarArg v
556 StgConApp con [] -> StgVarArg (dataConWorkId con)
557 StgLit lit -> StgLitArg lit
558 _ -> pprPanic "coreToStgArgs" (ppr arg)
560 -- WARNING: what if we have an argument like (v `cast` co)
561 -- where 'co' changes the representation type?
562 -- (This really only happens if co is unsafe.)
563 -- Then all the getArgAmode stuff in CgBindery will set the
564 -- cg_rep of the CgIdInfo based on the type of v, rather
565 -- than the type of 'co'.
566 -- This matters particularly when the function is a primop
568 -- Wanted: a better solution than this hacky warning
570 arg_ty = exprType arg
571 stg_arg_ty = stgArgType stg_arg
572 bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
573 || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
574 -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
575 -- and pass it to a function expecting an HValue (arg_ty). This is ok because
576 -- we can treat an unlifted value as lifted. But the other way round
578 -- We also want to check if a pointer is cast to a non-ptr etc
580 WARN( bad_args, ptext SLIT("Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
581 returnLne (stg_arg : stg_args, fvs)
584 -- ---------------------------------------------------------------------------
585 -- The magic for lets:
586 -- ---------------------------------------------------------------------------
589 :: Bool -- True <=> yes, we are let-no-escaping this let
590 -> CoreBind -- bindings
592 -> LneM (StgExpr, -- new let
593 FreeVarsInfo, -- variables free in the whole let
594 EscVarsSet, -- variables that escape from the whole let
595 Bool) -- True <=> none of the binders in the bindings
596 -- is among the escaping vars
598 coreToStgLet let_no_escape bind body
599 = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
601 -- Do the bindings, setting live_in_cont to empty if
602 -- we ain't in a let-no-escape world
603 getVarsLiveInCont `thenLne` \ live_in_cont ->
604 setVarsLiveInCont (if let_no_escape
607 (vars_bind rec_body_fvs bind)
608 `thenLne` \ ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext) ->
611 extendVarEnvLne env_ext (
612 coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
613 freeVarsToLiveVars body_fvs `thenLne` \ body_lv_info ->
615 returnLne (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
616 body2, body_fvs, body_escs, getLiveVars body_lv_info)
619 ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
620 body2, body_fvs, body_escs, body_lvs) ->
623 -- Compute the new let-expression
625 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
626 | otherwise = StgLet bind2 body2
629 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
632 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
634 real_bind_escs = if let_no_escape then
638 -- Everything escapes which is free in the bindings
640 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
642 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
645 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
648 -- Debugging code as requested by Andrew Kennedy
649 checked_no_binder_escapes
650 | not no_binder_escapes && any is_join_var binders
651 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
653 | otherwise = no_binder_escapes
655 checked_no_binder_escapes = no_binder_escapes
658 -- Mustn't depend on the passed-in let_no_escape flag, since
659 -- no_binder_escapes is used by the caller to derive the flag!
665 checked_no_binder_escapes
668 set_of_binders = mkVarSet binders
669 binders = bindersOf bind
671 mk_binding bind_lv_info binder rhs
672 = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
674 live_vars | let_no_escape = addLiveVar bind_lv_info binder
675 | otherwise = unitLiveVar binder
676 -- c.f. the invariant on NestedLet
678 vars_bind :: FreeVarsInfo -- Free var info for body of binding
682 EscVarsSet, -- free vars; escapee vars
683 LiveInfo, -- Vars and CAFs live in binding
684 [(Id, HowBound)]) -- extension to environment
687 vars_bind body_fvs (NonRec binder rhs)
688 = coreToStgRhs body_fvs [] (binder,rhs)
689 `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) ->
691 env_ext_item = mk_binding bind_lv_info binder rhs
693 returnLne (StgNonRec binder rhs2,
694 bind_fvs, escs, bind_lv_info, [env_ext_item])
697 vars_bind body_fvs (Rec pairs)
698 = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
700 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
701 binders = map fst pairs
702 env_ext = [ mk_binding bind_lv_info b rhs
705 extendVarEnvLne env_ext (
706 mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs
707 `thenLne` \ (rhss2, fvss, lv_infos, escss) ->
709 bind_fvs = unionFVInfos fvss
710 bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
711 escs = unionVarSets escss
713 returnLne (StgRec (binders `zip` rhss2),
714 bind_fvs, escs, bind_lv_info, env_ext)
718 is_join_var :: Id -> Bool
719 -- A hack (used only for compiler debuggging) to tell if
720 -- a variable started life as a join point ($j)
721 is_join_var j = occNameString (getOccName j) == "$j"
725 coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
728 -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
730 coreToStgRhs scope_fv_info binders (bndr, rhs)
731 = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) ->
732 getEnvLne `thenLne` \ env ->
733 freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info ->
734 returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
735 rhs_fvs, lv_info, rhs_escs)
737 bndr_info = lookupFVInfo scope_fv_info bndr
739 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
741 mkStgRhs rhs_fvs srt binder_info (StgConApp con args)
742 = StgRhsCon noCCS con args
744 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
745 = StgRhsClosure noCCS binder_info
750 mkStgRhs rhs_fvs srt binder_info rhs
751 = StgRhsClosure noCCS binder_info
757 SDM: disabled. Eval/Apply can't handle functions with arity zero very
758 well; and making these into simple non-updatable thunks breaks other
759 assumptions (namely that they will be entered only once).
761 upd_flag | isPAP env rhs = ReEntrant
762 | otherwise = Updatable
766 upd = if isOnceDem dem
767 then (if isNotTop toplev
768 then SingleEntry -- HA! Paydirt for "dem"
771 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
775 -- For now we forbid SingleEntry CAFs; they tickle the
776 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
777 -- and I don't understand why. There's only one SE_CAF (well,
778 -- only one that tickled a great gaping bug in an earlier attempt
779 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
780 -- specifically Main.lvl6 in spectral/cryptarithm2.
781 -- So no great loss. KSW 2000-07.
785 Detect thunks which will reduce immediately to PAPs, and make them
786 non-updatable. This has several advantages:
788 - the non-updatable thunk behaves exactly like the PAP,
790 - the thunk is more efficient to enter, because it is
791 specialised to the task.
793 - we save one update frame, one stg_update_PAP, one update
794 and lots of PAP_enters.
796 - in the case where the thunk is top-level, we save building
797 a black hole and futhermore the thunk isn't considered to
798 be a CAF any more, so it doesn't appear in any SRTs.
800 We do it here, because the arity information is accurate, and we need
801 to do it before the SRT pass to save the SRT entries associated with
804 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
806 arity = stgArity f (lookupBinding env f)
810 %************************************************************************
812 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
814 %************************************************************************
816 There's a lot of stuff to pass around, so we use this @LneM@ monad to
817 help. All the stuff here is only passed *down*.
820 type LneM a = IdEnv HowBound
821 -> LiveInfo -- Vars and CAFs live in continuation
824 type LiveInfo = (StgLiveVars, -- Dynamic live variables;
825 -- i.e. ones with a nested (non-top-level) binding
826 CafSet) -- Static live variables;
827 -- i.e. top-level variables that are CAFs or refer to them
829 type EscVarsSet = IdSet
833 = ImportBound -- Used only as a response to lookupBinding; never
834 -- exists in the range of the (IdEnv HowBound)
836 | LetBound -- A let(rec) in this module
837 LetInfo -- Whether top level or nested
838 Arity -- Its arity (local Ids don't have arity info at this point)
840 | LambdaBound -- Used for both lambda and case
843 = TopLet -- top level things
844 | NestedLet LiveInfo -- For nested things, what is live if this
845 -- thing is live? Invariant: the binder
846 -- itself is always a member of
847 -- the dynamic set of its own LiveInfo
849 isLetBound (LetBound _ _) = True
850 isLetBound other = False
852 topLevelBound ImportBound = True
853 topLevelBound (LetBound TopLet _) = True
854 topLevelBound other = False
857 For a let(rec)-bound variable, x, we record LiveInfo, the set of
858 variables that are live if x is live. This LiveInfo comprises
859 (a) dynamic live variables (ones with a non-top-level binding)
860 (b) static live variabes (CAFs or things that refer to CAFs)
862 For "normal" variables (a) is just x alone. If x is a let-no-escaped
863 variable then x is represented by a code pointer and a stack pointer
864 (well, one for each stack). So all of the variables needed in the
865 execution of x are live if x is, and are therefore recorded in the
866 LetBound constructor; x itself *is* included.
868 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
872 emptyLiveInfo :: LiveInfo
873 emptyLiveInfo = (emptyVarSet,emptyVarSet)
875 unitLiveVar :: Id -> LiveInfo
876 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
878 unitLiveCaf :: Id -> LiveInfo
879 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
881 addLiveVar :: LiveInfo -> Id -> LiveInfo
882 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
884 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
885 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
887 mkSRT :: LiveInfo -> SRT
888 mkSRT (_, cafs) = SRTEntries cafs
890 getLiveVars :: LiveInfo -> StgLiveVars
891 getLiveVars (lvs, _) = lvs
895 The std monad functions:
897 initLne :: IdEnv HowBound -> LneM a -> a
898 initLne env m = m env emptyLiveInfo
902 {-# INLINE thenLne #-}
903 {-# INLINE returnLne #-}
905 returnLne :: a -> LneM a
906 returnLne e env lvs_cont = e
908 thenLne :: LneM a -> (a -> LneM b) -> LneM b
909 thenLne m k env lvs_cont
910 = k (m env lvs_cont) env lvs_cont
912 mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c])
913 mapAndUnzipLne f [] = returnLne ([],[])
914 mapAndUnzipLne f (x:xs)
915 = f x `thenLne` \ (r1, r2) ->
916 mapAndUnzipLne f xs `thenLne` \ (rs1, rs2) ->
917 returnLne (r1:rs1, r2:rs2)
919 mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d])
920 mapAndUnzip3Lne f [] = returnLne ([],[],[])
921 mapAndUnzip3Lne f (x:xs)
922 = f x `thenLne` \ (r1, r2, r3) ->
923 mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) ->
924 returnLne (r1:rs1, r2:rs2, r3:rs3)
926 mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e])
927 mapAndUnzip4Lne f [] = returnLne ([],[],[],[])
928 mapAndUnzip4Lne f (x:xs)
929 = f x `thenLne` \ (r1, r2, r3, r4) ->
930 mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) ->
931 returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
933 fixLne :: (a -> LneM a) -> LneM a
934 fixLne expr env lvs_cont
937 result = expr result env lvs_cont
940 Functions specific to this monad:
943 getVarsLiveInCont :: LneM LiveInfo
944 getVarsLiveInCont env lvs_cont = lvs_cont
946 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
947 setVarsLiveInCont new_lvs_cont expr env lvs_cont
948 = expr env new_lvs_cont
950 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
951 extendVarEnvLne ids_w_howbound expr env lvs_cont
952 = expr (extendVarEnvList env ids_w_howbound) lvs_cont
954 lookupVarLne :: Id -> LneM HowBound
955 lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont
957 getEnvLne :: LneM (IdEnv HowBound)
958 getEnvLne env lvs_cont = returnLne env env lvs_cont
960 lookupBinding :: IdEnv HowBound -> Id -> HowBound
961 lookupBinding env v = case lookupVarEnv env v of
963 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
966 -- The result of lookupLiveVarsForSet, a set of live variables, is
967 -- only ever tacked onto a decorated expression. It is never used as
968 -- the basis of a control decision, which might give a black hole.
970 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
971 freeVarsToLiveVars fvs env live_in_cont
972 = returnLne live_info env live_in_cont
974 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
975 lvs_from_fvs = map do_one (allFreeIds fvs)
977 do_one (v, how_bound)
979 ImportBound -> unitLiveCaf v -- Only CAF imports are
982 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
983 | otherwise -> emptyLiveInfo
985 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
986 -- (see the invariant on NestedLet)
988 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
991 %************************************************************************
993 \subsection[Free-var info]{Free variable information}
995 %************************************************************************
998 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
999 -- The Var is so we can gather up the free variables
1002 -- The HowBound info just saves repeated lookups;
1003 -- we look up just once when we encounter the occurrence.
1004 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
1005 -- Imported Ids without CAF refs are simply
1006 -- not put in the FreeVarsInfo for an expression.
1007 -- See singletonFVInfo and freeVarsToLiveVars
1009 -- StgBinderInfo records how it occurs; notably, we
1010 -- are interested in whether it only occurs in saturated
1011 -- applications, because then we don't need to build a
1013 -- If f is mapped to noBinderInfo, that means
1014 -- that f *is* mentioned (else it wouldn't be in the
1015 -- IdEnv at all), but perhaps in an unsaturated applications.
1017 -- All case/lambda-bound things are also mapped to
1018 -- noBinderInfo, since we aren't interested in their
1021 -- For ILX we track free var info for type variables too;
1022 -- hence VarEnv not IdEnv
1026 emptyFVInfo :: FreeVarsInfo
1027 emptyFVInfo = emptyVarEnv
1029 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1030 -- Don't record non-CAF imports at all, to keep free-var sets small
1031 singletonFVInfo id ImportBound info
1032 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1033 | otherwise = emptyVarEnv
1034 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
1036 tyvarFVInfo :: TyVarSet -> FreeVarsInfo
1037 tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
1039 add tv fvs = extendVarEnv fvs tv (tv, LambdaBound, noBinderInfo)
1040 -- Type variables must be lambda-bound
1042 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1043 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1045 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1046 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1048 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1049 minusFVBinders vs fv = foldr minusFVBinder fv vs
1051 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1052 minusFVBinder v fv | isId v && opt_RuntimeTypes
1053 = (fv `delVarEnv` v) `unionFVInfo`
1054 tyvarFVInfo (tyVarsOfType (idType v))
1055 | otherwise = fv `delVarEnv` v
1056 -- When removing a binder, remember to add its type variables
1057 -- c.f. CoreFVs.delBinderFV
1059 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1060 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1062 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1063 -- Find how the given Id is used.
1064 -- Externally visible things may be used any old how
1066 | isExternalName (idName id) = noBinderInfo
1067 | otherwise = case lookupVarEnv fvs id of
1068 Nothing -> noBinderInfo
1069 Just (_,_,info) -> info
1071 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1072 allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id]
1074 -- Non-top-level things only, both type variables and ids
1075 -- (type variables only if opt_RuntimeTypes)
1076 getFVs :: FreeVarsInfo -> [Var]
1077 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
1078 not (topLevelBound how_bound) ]
1080 getFVSet :: FreeVarsInfo -> VarSet
1081 getFVSet fvs = mkVarSet (getFVs fvs)
1083 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1084 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1085 (id1, hb1, combineStgBinderInfo info1 info2)
1087 -- The HowBound info for a variable in the FVInfo should be consistent
1088 check_eq_how_bound ImportBound ImportBound = True
1089 check_eq_how_bound LambdaBound LambdaBound = True
1090 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1091 check_eq_how_bound hb1 hb2 = False
1093 check_eq_li (NestedLet _) (NestedLet _) = True
1094 check_eq_li TopLet TopLet = True
1095 check_eq_li li1 li2 = False
1100 filterStgBinders :: [Var] -> [Var]
1101 filterStgBinders bndrs
1102 | opt_RuntimeTypes = bndrs
1103 | otherwise = filter isId bndrs
1108 -- Ignore all notes except SCC
1109 myCollectBinders expr
1112 go bs (Lam b e) = go (b:bs) e
1113 go bs e@(Note (SCC _) _) = (reverse bs, e)
1114 go bs (Cast e co) = go bs e
1115 go bs (Note _ e) = go bs e
1116 go bs e = (reverse bs, e)
1118 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1119 -- We assume that we only have variables
1120 -- in the function position by now
1124 go (Var v) as = (v, as)
1125 go (App f a) as = go f (a:as)
1126 go (Note (SCC _) e) as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1127 go (Cast e co) as = go e as
1128 go (Note n e) as = go e as
1129 go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1133 stgArity :: Id -> HowBound -> Arity
1134 stgArity f (LetBound _ arity) = arity
1135 stgArity f ImportBound = idArity f
1136 stgArity f LambdaBound = 0