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"
15 import CoreUtils ( rhsIsStatic, manifestArity, exprType, findDefault )
24 import CostCentre ( noCCS )
27 import Maybes ( maybeToBool )
28 import Name ( getOccName, isExternalName, nameOccName )
29 import OccName ( occNameString, occNameFS )
30 import BasicTypes ( Arity )
38 %************************************************************************
40 \subsection[live-vs-free-doc]{Documentation}
42 %************************************************************************
44 (There is other relevant documentation in codeGen/CgLetNoEscape.)
46 The actual Stg datatype is decorated with {\em live variable}
47 information, as well as {\em free variable} information. The two are
48 {\em not} the same. Liveness is an operational property rather than a
49 semantic one. A variable is live at a particular execution point if
50 it can be referred to {\em directly} again. In particular, a dead
51 variable's stack slot (if it has one):
54 should be stubbed to avoid space leaks, and
56 may be reused for something else.
59 There ought to be a better way to say this. Here are some examples:
66 Just after the `in', v is live, but q is dead. If the whole of that
67 let expression was enclosed in a case expression, thus:
69 case (let v = [q] \[x] -> e in ...v...) of
72 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
73 we'll return later to the @alts@ and need it.
75 Let-no-escapes make this a bit more interesting:
77 let-no-escape v = [q] \ [x] -> e
81 Here, @q@ is still live at the `in', because @v@ is represented not by
82 a closure but by the current stack state. In other words, if @v@ is
83 live then so is @q@. Furthermore, if @e@ mentions an enclosing
84 let-no-escaped variable, then {\em its} free variables are also live
87 %************************************************************************
89 \subsection[caf-info]{Collecting live CAF info}
91 %************************************************************************
93 In this pass we also collect information on which CAFs are live for
94 constructing SRTs (see SRT.lhs).
96 A top-level Id has CafInfo, which is
98 - MayHaveCafRefs, if it may refer indirectly to
100 - NoCafRefs if it definitely doesn't
102 The CafInfo has already been calculated during the CoreTidy pass.
104 During CoreToStg, we then pin onto each binding and case expression, a
105 list of Ids which represents the "live" CAFs at that point. The meaning
106 of "live" here is the same as for live variables, see above (which is
107 why it's convenient to collect CAF information here rather than elsewhere).
109 The later SRT pass takes these lists of Ids and uses them to construct
110 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
114 Interaction of let-no-escape with SRTs [Sept 01]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
118 let-no-escape x = ...caf1...caf2...
122 where caf1,caf2 are CAFs. Since x doesn't have a closure, we
123 build SRTs just as if x's defn was inlined at each call site, and
124 that means that x's CAF refs get duplicated in the overall SRT.
126 This is unlike ordinary lets, in which the CAF refs are not duplicated.
128 We could fix this loss of (static) sharing by making a sort of pseudo-closure
129 for x, solely to put in the SRTs lower down.
132 %************************************************************************
134 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
136 %************************************************************************
139 coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
140 coreToStg this_pkg pgm
142 where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
144 coreExprToStg :: CoreExpr -> StgExpr
146 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
151 -> IdEnv HowBound -- environment for the bindings
153 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
155 coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
156 coreTopBindsToStg this_pkg env (b:bs)
157 = (env2, fvs2, b':bs')
159 -- Notice the mutually-recursive "knot" here:
160 -- env accumulates down the list of binds,
161 -- fvs accumulates upwards
162 (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
163 (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
168 -> FreeVarsInfo -- Info about the body
170 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
172 coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
174 env' = extendVarEnv env id how_bound
175 how_bound = LetBound TopLet $! manifestArity rhs
179 (stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
180 return (stg_rhs, fvs')
182 bind = StgNonRec id stg_rhs
184 ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind )
185 (env', fvs' `unionFVInfo` body_fvs, bind)
187 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
188 = ASSERT( not (null pairs) )
190 binders = map fst pairs
192 extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
193 | (b, rhs) <- pairs ]
194 env' = extendVarEnvList env extra_env'
198 (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
199 let fvs' = unionFVInfos fvss'
200 return (stg_rhss, fvs')
202 bind = StgRec (zip binders stg_rhss)
204 ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
205 (env', fvs' `unionFVInfo` body_fvs, bind)
208 -- Assertion helper: this checks that the CafInfo on the Id matches
209 -- what CoreToStg has figured out about the binding's SRT. The
210 -- CafInfo will be exact in all cases except when CorePrep has
211 -- floated out a binding, in which case it will be approximate.
212 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
213 consistentCafInfo id bind
214 | occNameFS (nameOccName (idName id)) == fsLit "sat"
217 = WARN (not exact, ppr id) safe
219 safe = id_marked_caffy || not binding_is_caffy
220 exact = id_marked_caffy == binding_is_caffy
221 id_marked_caffy = mayHaveCafRefs (idCafInfo id)
222 binding_is_caffy = stgBindHasCafRefs bind
228 -> FreeVarsInfo -- Free var info for the scope of the binding
230 -> LneM (StgRhs, FreeVarsInfo)
232 coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
233 = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
234 ; lv_info <- freeVarsToLiveVars rhs_fvs
236 ; let stg_rhs = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs
237 stg_arity = stgRhsArity stg_rhs
238 ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
241 bndr_info = lookupFVInfo scope_fv_info bndr
242 is_static = rhsIsStatic this_pkg rhs
244 -- It's vital that the arity on a top-level Id matches
245 -- the arity of the generated STG binding, else an importing
246 -- module will use the wrong calling convention
247 -- (Trac #2844 was an example where this happened)
248 -- NB1: we can't move the assertion further out without
249 -- blocking the "knot" tied in coreTopBindsToStg
250 -- NB2: the arity check is only needed for Ids with External
251 -- Names, because they are externally visible. The CorePrep
252 -- pass introduces "sat" things with Local Names and does
253 -- not bother to set their Arity info, so don't fail for those
255 | isExternalName (idName bndr) = id_arity == stg_arity
257 id_arity = idArity bndr
258 mk_arity_msg stg_arity
260 ptext (sLit "Id arity:") <+> ppr id_arity,
261 ptext (sLit "STG arity:") <+> ppr stg_arity]
263 mkTopStgRhs :: Bool -> FreeVarsInfo
264 -> SRT -> StgBinderInfo -> StgExpr
267 mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
268 = ASSERT( is_static )
269 StgRhsClosure noCCS binder_info
275 mkTopStgRhs is_static _ _ _ (StgConApp con args)
276 | is_static -- StgConApps can be updatable (see isCrossDllConApp)
277 = StgRhsCon noCCS con args
279 mkTopStgRhs is_static rhs_fvs srt binder_info rhs
280 = ASSERT2( not is_static, ppr rhs )
281 StgRhsClosure noCCS binder_info
289 -- ---------------------------------------------------------------------------
291 -- ---------------------------------------------------------------------------
296 -> LneM (StgExpr, -- Decorated STG expr
297 FreeVarsInfo, -- Its free vars (NB free, not live)
298 EscVarsSet) -- Its escapees, a subset of its free vars;
299 -- also a subset of the domain of the envt
300 -- because we are only interested in the escapees
301 -- for vars which might be turned into
302 -- let-no-escaped ones.
305 The second and third components can be derived in a simple bottom up pass, not
306 dependent on any decisions about which variables will be let-no-escaped or
307 not. The first component, that is, the decorated expression, may then depend
308 on these components, but it in turn is not scrutinised as the basis for any
309 decisions. Hence no black holes.
312 coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
313 coreToStgExpr (Var v) = coreToStgApp Nothing v []
315 coreToStgExpr expr@(App _ _)
316 = coreToStgApp Nothing f args
318 (f, args) = myCollectArgs expr
320 coreToStgExpr expr@(Lam _ _)
322 (args, body) = myCollectBinders expr
323 args' = filterStgBinders args
325 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
326 (body, body_fvs, body_escs) <- coreToStgExpr body
328 fvs = args' `minusFVBinders` body_fvs
329 escs = body_escs `delVarSetList` args'
330 result_expr | null args' = body
331 | otherwise = StgLam (exprType expr) args' body
333 return (result_expr, fvs, escs)
335 coreToStgExpr (Note (SCC cc) expr) = do
336 (expr2, fvs, escs) <- coreToStgExpr expr
337 return (StgSCC cc expr2, fvs, escs)
339 coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)])
340 | Just (TickBox m n) <- isTickBoxOp_maybe id = do
341 (expr2, fvs, escs) <- coreToStgExpr expr
342 return (StgTick m n expr2, fvs, escs)
344 coreToStgExpr (Note _ expr)
347 coreToStgExpr (Cast expr _)
350 -- Cases require a little more real work.
352 coreToStgExpr (Case scrut bndr _ alts) = do
353 (alts2, alts_fvs, alts_escs)
354 <- extendVarEnvLne [(bndr, LambdaBound)] $ do
355 (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
358 unionVarSets escs_s )
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' | bndr `elementOfFVInfo` alts_fvs = bndr
364 | otherwise = bndr `setIdOccInfo` IAmDead
366 -- Don't consider the default binder as being 'live in alts',
367 -- since this is from the point of view of the case expr, where
368 -- the default binder is not free.
369 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
370 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
372 alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
374 -- We tell the scrutinee that everything
375 -- live in the alts is live in it, too.
376 (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
377 <- setVarsLiveInCont alts_lv_info $ do
378 (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
379 scrut_lv_info <- freeVarsToLiveVars scrut_fvs
380 return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
383 StgCase scrut2 (getLiveVars scrut_lv_info)
384 (getLiveVars alts_lv_info)
387 (mkStgAltType bndr alts)
389 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
390 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
391 -- You might think we should have scrut_escs, not
392 -- (getFVSet scrut_fvs), but actually we can't call, and
393 -- then return from, a let-no-escape thing.
396 vars_alt (con, binders, rhs)
397 = let -- Remove type variables
398 binders' = filterStgBinders binders
400 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
401 (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
403 -- Records whether each param is used in the RHS
404 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
406 return ( (con, binders', good_use_mask, rhs2),
407 binders' `minusFVBinders` rhs_fvs,
408 rhs_escs `delVarSetList` binders' )
409 -- ToDo: remove the delVarSet;
410 -- since escs won't include any of these binders
413 Lets not only take quite a bit of work, but this is where we convert
414 then to let-no-escapes, if we wish.
416 (Meanwhile, we don't expect to see let-no-escapes...)
418 coreToStgExpr (Let bind body) = do
419 (new_let, fvs, escs, _)
420 <- mfix (\ ~(_, _, _, no_binder_escapes) ->
421 coreToStgLet no_binder_escapes bind body
424 return (new_let, fvs, escs)
426 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
430 mkStgAltType :: Id -> [CoreAlt] -> AltType
431 mkStgAltType bndr alts
432 = case splitTyConApp_maybe (repType (idType bndr)) of
433 Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
434 | isUnLiftedTyCon tc -> PrimAlt tc
435 | isHiBootTyCon tc -> look_for_better_tycon
436 | isAlgTyCon tc -> AlgAlt tc
437 | otherwise -> ASSERT( _is_poly_alt_tycon tc )
442 _is_poly_alt_tycon tc
444 || isPrimTyCon tc -- "Any" is lifted but primitive
445 || isOpenTyCon tc -- Type family; e.g. arising from strict
446 -- function application where argument has a
449 -- Sometimes, the TyCon is a HiBootTyCon which may not have any
450 -- constructors inside it. Then we can get a better TyCon by
451 -- grabbing the one from a constructor alternative
453 look_for_better_tycon
454 | ((DataAlt con, _, _) : _) <- data_alts =
455 AlgAlt (dataConTyCon con)
457 ASSERT(null data_alts)
460 (data_alts, _deflt) = findDefault alts
464 -- ---------------------------------------------------------------------------
466 -- ---------------------------------------------------------------------------
470 :: Maybe UpdateFlag -- Just upd <=> this application is
471 -- the rhs of a thunk binding
472 -- x = [...] \upd [] -> the_app
473 -- with specified update flag
475 -> [CoreArg] -- Arguments
476 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
479 coreToStgApp _ f args = do
480 (args', args_fvs) <- coreToStgArgs args
481 how_bound <- lookupVarLne f
484 n_val_args = valArgCount args
485 not_letrec_bound = not (isLetBound how_bound)
486 fun_fvs = singletonFVInfo f how_bound fun_occ
487 -- e.g. (f :: a -> int) (x :: a)
488 -- Here the free variables are "f", "x" AND the type variable "a"
489 -- coreToStgArgs will deal with the arguments recursively
491 -- Mostly, the arity info of a function is in the fn's IdInfo
492 -- But new bindings introduced by CoreSat may not have no
493 -- arity info; it would do us no good anyway. For example:
494 -- let f = \ab -> e in f
495 -- No point in having correct arity info for f!
496 -- Hence the hasArity stuff below.
497 -- NB: f_arity is only consulted for LetBound things
498 f_arity = stgArity f how_bound
499 saturated = f_arity <= n_val_args
502 | not_letrec_bound = noBinderInfo -- Uninteresting variable
503 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
504 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
507 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
508 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
509 -- saturated call doesn't escape
510 -- (let-no-escape applies to 'thunks' too)
512 | otherwise = unitVarSet f -- Inexact application; it does escape
514 -- At the moment of the call:
516 -- either the function is *not* let-no-escaped, in which case
517 -- nothing is live except live_in_cont
518 -- or the function *is* let-no-escaped in which case the
519 -- variables it uses are live, but still the function
520 -- itself is not. PS. In this case, the function's
521 -- live vars should already include those of the
522 -- continuation, but it does no harm to just union the
525 res_ty = exprType (mkApps (Var f) args)
526 app = case globalIdDetails f of
527 DataConWorkId dc | saturated -> StgConApp dc args'
528 PrimOpId op -> ASSERT( saturated )
529 StgOpApp (StgPrimOp op) args' res_ty
530 FCallId call -> ASSERT( saturated )
531 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
532 TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
533 _other -> StgApp f args'
537 fun_fvs `unionFVInfo` args_fvs,
538 fun_escs `unionVarSet` (getFVSet args_fvs)
539 -- All the free vars of the args are disqualified
540 -- from being let-no-escaped.
545 -- ---------------------------------------------------------------------------
547 -- This is the guy that turns applications into A-normal form
548 -- ---------------------------------------------------------------------------
550 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
552 = return ([], emptyFVInfo)
554 coreToStgArgs (Type _ : args) = do -- Type argument
555 (args', fvs) <- coreToStgArgs args
558 coreToStgArgs (arg : args) = do -- Non-type argument
559 (stg_args, args_fvs) <- coreToStgArgs args
560 (arg', arg_fvs, _escs) <- coreToStgExpr arg
562 fvs = args_fvs `unionFVInfo` arg_fvs
563 stg_arg = case arg' of
564 StgApp v [] -> StgVarArg v
565 StgConApp con [] -> StgVarArg (dataConWorkId con)
566 StgLit lit -> StgLitArg lit
567 _ -> pprPanic "coreToStgArgs" (ppr arg)
569 -- WARNING: what if we have an argument like (v `cast` co)
570 -- where 'co' changes the representation type?
571 -- (This really only happens if co is unsafe.)
572 -- Then all the getArgAmode stuff in CgBindery will set the
573 -- cg_rep of the CgIdInfo based on the type of v, rather
574 -- than the type of 'co'.
575 -- This matters particularly when the function is a primop
577 -- Wanted: a better solution than this hacky warning
579 arg_ty = exprType arg
580 stg_arg_ty = stgArgType stg_arg
581 bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
582 || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
583 -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
584 -- and pass it to a function expecting an HValue (arg_ty). This is ok because
585 -- we can treat an unlifted value as lifted. But the other way round
587 -- We also want to check if a pointer is cast to a non-ptr etc
589 WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
590 return (stg_arg : stg_args, fvs)
593 -- ---------------------------------------------------------------------------
594 -- The magic for lets:
595 -- ---------------------------------------------------------------------------
598 :: Bool -- True <=> yes, we are let-no-escaping this let
599 -> CoreBind -- bindings
601 -> LneM (StgExpr, -- new let
602 FreeVarsInfo, -- variables free in the whole let
603 EscVarsSet, -- variables that escape from the whole let
604 Bool) -- True <=> none of the binders in the bindings
605 -- is among the escaping vars
607 coreToStgLet let_no_escape bind body = do
608 (bind2, bind_fvs, bind_escs, bind_lvs,
609 body2, body_fvs, body_escs, body_lvs)
610 <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
612 -- Do the bindings, setting live_in_cont to empty if
613 -- we ain't in a let-no-escape world
614 live_in_cont <- getVarsLiveInCont
615 ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
616 <- setVarsLiveInCont (if let_no_escape
619 (vars_bind rec_body_fvs bind)
622 extendVarEnvLne env_ext $ do
623 (body2, body_fvs, body_escs) <- coreToStgExpr body
624 body_lv_info <- freeVarsToLiveVars body_fvs
626 return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
627 body2, body_fvs, body_escs, getLiveVars body_lv_info)
630 -- Compute the new let-expression
632 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
633 | otherwise = StgLet bind2 body2
636 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
639 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
641 real_bind_escs = if let_no_escape then
645 -- Everything escapes which is free in the bindings
647 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
649 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
652 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
654 -- Debugging code as requested by Andrew Kennedy
655 checked_no_binder_escapes
656 | debugIsOn && not no_binder_escapes && any is_join_var binders
657 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
659 | otherwise = no_binder_escapes
661 -- Mustn't depend on the passed-in let_no_escape flag, since
662 -- no_binder_escapes is used by the caller to derive the flag!
667 checked_no_binder_escapes
670 set_of_binders = mkVarSet binders
671 binders = bindersOf bind
673 mk_binding bind_lv_info binder rhs
674 = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
676 live_vars | let_no_escape = addLiveVar bind_lv_info binder
677 | otherwise = unitLiveVar binder
678 -- c.f. the invariant on NestedLet
680 vars_bind :: FreeVarsInfo -- Free var info for body of binding
684 EscVarsSet, -- free vars; escapee vars
685 LiveInfo, -- Vars and CAFs live in binding
686 [(Id, HowBound)]) -- extension to environment
689 vars_bind body_fvs (NonRec binder rhs) = do
690 (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
692 env_ext_item = mk_binding bind_lv_info binder rhs
694 return (StgNonRec binder rhs2,
695 bind_fvs, escs, bind_lv_info, [env_ext_item])
698 vars_bind body_fvs (Rec pairs)
699 = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
701 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
702 binders = map fst pairs
703 env_ext = [ mk_binding bind_lv_info b rhs
706 extendVarEnvLne env_ext $ do
707 (rhss2, fvss, lv_infos, escss)
708 <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
710 bind_fvs = unionFVInfos fvss
711 bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
712 escs = unionVarSets escss
714 return (StgRec (binders `zip` rhss2),
715 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) = do
731 (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
732 lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
733 return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
734 rhs_fvs, lv_info, rhs_escs)
736 bndr_info = lookupFVInfo scope_fv_info bndr
738 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
740 mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
742 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
743 = StgRhsClosure noCCS binder_info
748 mkStgRhs rhs_fvs srt binder_info rhs
749 = StgRhsClosure noCCS binder_info
755 SDM: disabled. Eval/Apply can't handle functions with arity zero very
756 well; and making these into simple non-updatable thunks breaks other
757 assumptions (namely that they will be entered only once).
759 upd_flag | isPAP env rhs = ReEntrant
760 | otherwise = Updatable
764 upd = if isOnceDem dem
765 then (if isNotTop toplev
766 then SingleEntry -- HA! Paydirt for "dem"
769 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
773 -- For now we forbid SingleEntry CAFs; they tickle the
774 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
775 -- and I don't understand why. There's only one SE_CAF (well,
776 -- only one that tickled a great gaping bug in an earlier attempt
777 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
778 -- specifically Main.lvl6 in spectral/cryptarithm2.
779 -- So no great loss. KSW 2000-07.
783 Detect thunks which will reduce immediately to PAPs, and make them
784 non-updatable. This has several advantages:
786 - the non-updatable thunk behaves exactly like the PAP,
788 - the thunk is more efficient to enter, because it is
789 specialised to the task.
791 - we save one update frame, one stg_update_PAP, one update
792 and lots of PAP_enters.
794 - in the case where the thunk is top-level, we save building
795 a black hole and futhermore the thunk isn't considered to
796 be a CAF any more, so it doesn't appear in any SRTs.
798 We do it here, because the arity information is accurate, and we need
799 to do it before the SRT pass to save the SRT entries associated with
802 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
804 arity = stgArity f (lookupBinding env f)
808 %************************************************************************
810 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
812 %************************************************************************
814 There's a lot of stuff to pass around, so we use this @LneM@ monad to
815 help. All the stuff here is only passed *down*.
818 newtype LneM a = LneM
819 { unLneM :: IdEnv HowBound
820 -> 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 :: HowBound -> Bool
850 isLetBound (LetBound _ _) = True
853 topLevelBound :: HowBound -> Bool
854 topLevelBound ImportBound = True
855 topLevelBound (LetBound TopLet _) = True
856 topLevelBound _ = False
859 For a let(rec)-bound variable, x, we record LiveInfo, the set of
860 variables that are live if x is live. This LiveInfo comprises
861 (a) dynamic live variables (ones with a non-top-level binding)
862 (b) static live variabes (CAFs or things that refer to CAFs)
864 For "normal" variables (a) is just x alone. If x is a let-no-escaped
865 variable then x is represented by a code pointer and a stack pointer
866 (well, one for each stack). So all of the variables needed in the
867 execution of x are live if x is, and are therefore recorded in the
868 LetBound constructor; x itself *is* included.
870 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
874 emptyLiveInfo :: LiveInfo
875 emptyLiveInfo = (emptyVarSet,emptyVarSet)
877 unitLiveVar :: Id -> LiveInfo
878 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
880 unitLiveCaf :: Id -> LiveInfo
881 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
883 addLiveVar :: LiveInfo -> Id -> LiveInfo
884 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
886 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
887 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
889 mkSRT :: LiveInfo -> SRT
890 mkSRT (_, cafs) = SRTEntries cafs
892 getLiveVars :: LiveInfo -> StgLiveVars
893 getLiveVars (lvs, _) = lvs
897 The std monad functions:
899 initLne :: IdEnv HowBound -> LneM a -> a
900 initLne env m = unLneM m env emptyLiveInfo
904 {-# INLINE thenLne #-}
905 {-# INLINE returnLne #-}
907 returnLne :: a -> LneM a
908 returnLne e = LneM $ \_ _ -> e
910 thenLne :: LneM a -> (a -> LneM b) -> LneM b
911 thenLne m k = LneM $ \env lvs_cont
912 -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
914 instance Monad LneM where
918 instance MonadFix LneM where
919 mfix expr = LneM $ \env lvs_cont ->
920 let result = unLneM (expr result) env lvs_cont
924 Functions specific to this monad:
927 getVarsLiveInCont :: LneM LiveInfo
928 getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
930 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
931 setVarsLiveInCont new_lvs_cont expr
932 = LneM $ \env _lvs_cont
933 -> unLneM expr env new_lvs_cont
935 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
936 extendVarEnvLne ids_w_howbound expr
937 = LneM $ \env lvs_cont
938 -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
940 lookupVarLne :: Id -> LneM HowBound
941 lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
943 lookupBinding :: IdEnv HowBound -> Id -> HowBound
944 lookupBinding env v = case lookupVarEnv env v of
946 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
949 -- The result of lookupLiveVarsForSet, a set of live variables, is
950 -- only ever tacked onto a decorated expression. It is never used as
951 -- the basis of a control decision, which might give a black hole.
953 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
954 freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
956 freeVarsToLiveVars' _env live_in_cont = live_info
958 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
959 lvs_from_fvs = map do_one (allFreeIds fvs)
961 do_one (v, how_bound)
963 ImportBound -> unitLiveCaf v -- Only CAF imports are
966 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
967 | otherwise -> emptyLiveInfo
969 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
970 -- (see the invariant on NestedLet)
972 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
975 %************************************************************************
977 \subsection[Free-var info]{Free variable information}
979 %************************************************************************
982 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
983 -- The Var is so we can gather up the free variables
986 -- The HowBound info just saves repeated lookups;
987 -- we look up just once when we encounter the occurrence.
988 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
989 -- Imported Ids without CAF refs are simply
990 -- not put in the FreeVarsInfo for an expression.
991 -- See singletonFVInfo and freeVarsToLiveVars
993 -- StgBinderInfo records how it occurs; notably, we
994 -- are interested in whether it only occurs in saturated
995 -- applications, because then we don't need to build a
997 -- If f is mapped to noBinderInfo, that means
998 -- that f *is* mentioned (else it wouldn't be in the
999 -- IdEnv at all), but perhaps in an unsaturated applications.
1001 -- All case/lambda-bound things are also mapped to
1002 -- noBinderInfo, since we aren't interested in their
1005 -- For ILX we track free var info for type variables too;
1006 -- hence VarEnv not IdEnv
1010 emptyFVInfo :: FreeVarsInfo
1011 emptyFVInfo = emptyVarEnv
1013 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1014 -- Don't record non-CAF imports at all, to keep free-var sets small
1015 singletonFVInfo id ImportBound info
1016 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1017 | otherwise = emptyVarEnv
1018 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
1020 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1021 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1023 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1024 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1026 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1027 minusFVBinders vs fv = foldr minusFVBinder fv vs
1029 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1030 minusFVBinder v fv = fv `delVarEnv` v
1031 -- When removing a binder, remember to add its type variables
1032 -- c.f. CoreFVs.delBinderFV
1034 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1035 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1037 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1038 -- Find how the given Id is used.
1039 -- Externally visible things may be used any old how
1041 | isExternalName (idName id) = noBinderInfo
1042 | otherwise = case lookupVarEnv fvs id of
1043 Nothing -> noBinderInfo
1044 Just (_,_,info) -> info
1046 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1047 allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
1049 ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
1051 -- Non-top-level things only, both type variables and ids
1052 getFVs :: FreeVarsInfo -> [Var]
1053 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
1054 not (topLevelBound how_bound) ]
1056 getFVSet :: FreeVarsInfo -> VarSet
1057 getFVSet fvs = mkVarSet (getFVs fvs)
1059 plusFVInfo :: (Var, HowBound, StgBinderInfo)
1060 -> (Var, HowBound, StgBinderInfo)
1061 -> (Var, HowBound, StgBinderInfo)
1062 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1063 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1064 (id1, hb1, combineStgBinderInfo info1 info2)
1066 -- The HowBound info for a variable in the FVInfo should be consistent
1067 check_eq_how_bound :: HowBound -> HowBound -> Bool
1068 check_eq_how_bound ImportBound ImportBound = True
1069 check_eq_how_bound LambdaBound LambdaBound = True
1070 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1071 check_eq_how_bound _ _ = False
1073 check_eq_li :: LetInfo -> LetInfo -> Bool
1074 check_eq_li (NestedLet _) (NestedLet _) = True
1075 check_eq_li TopLet TopLet = True
1076 check_eq_li _ _ = False
1081 filterStgBinders :: [Var] -> [Var]
1082 filterStgBinders bndrs = filter isId bndrs
1087 -- Ignore all notes except SCC
1088 myCollectBinders :: Expr Var -> ([Var], Expr Var)
1089 myCollectBinders expr
1092 go bs (Lam b e) = go (b:bs) e
1093 go bs e@(Note (SCC _) _) = (reverse bs, e)
1094 go bs (Cast e _) = go bs e
1095 go bs (Note _ e) = go bs e
1096 go bs e = (reverse bs, e)
1098 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1099 -- We assume that we only have variables
1100 -- in the function position by now
1104 go (Var v) as = (v, as)
1105 go (App f a) as = go f (a:as)
1106 go (Note (SCC _) _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1107 go (Cast e _) as = go e as
1108 go (Note _ e) as = go e as
1110 | isTyVar b = go e as -- Note [Collect args]
1111 go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1116 This big-lambda case occurred following a rather obscure eta expansion.
1117 It all seems a bit yukky to me.
1120 stgArity :: Id -> HowBound -> Arity
1121 stgArity _ (LetBound _ arity) = arity
1122 stgArity f ImportBound = idArity f
1123 stgArity _ LambdaBound = 0