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 ( exprType, findDefault )
16 import CoreArity ( manifestArity )
25 import CostCentre ( noCCS )
28 import Maybes ( maybeToBool )
29 import Name ( getOccName, isExternalName, nameOccName )
30 import OccName ( occNameString, occNameFS )
31 import BasicTypes ( Arity )
38 import PrimOp ( PrimCall(..) )
41 %************************************************************************
43 \subsection[live-vs-free-doc]{Documentation}
45 %************************************************************************
47 (There is other relevant documentation in codeGen/CgLetNoEscape.)
49 The actual Stg datatype is decorated with {\em live variable}
50 information, as well as {\em free variable} information. The two are
51 {\em not} the same. Liveness is an operational property rather than a
52 semantic one. A variable is live at a particular execution point if
53 it can be referred to {\em directly} again. In particular, a dead
54 variable's stack slot (if it has one):
57 should be stubbed to avoid space leaks, and
59 may be reused for something else.
62 There ought to be a better way to say this. Here are some examples:
69 Just after the `in', v is live, but q is dead. If the whole of that
70 let expression was enclosed in a case expression, thus:
72 case (let v = [q] \[x] -> e in ...v...) of
75 (ie @alts@ mention @q@), then @q@ is live even after the `in'; because
76 we'll return later to the @alts@ and need it.
78 Let-no-escapes make this a bit more interesting:
80 let-no-escape v = [q] \ [x] -> e
84 Here, @q@ is still live at the `in', because @v@ is represented not by
85 a closure but by the current stack state. In other words, if @v@ is
86 live then so is @q@. Furthermore, if @e@ mentions an enclosing
87 let-no-escaped variable, then {\em its} free variables are also live
90 %************************************************************************
92 \subsection[caf-info]{Collecting live CAF info}
94 %************************************************************************
96 In this pass we also collect information on which CAFs are live for
97 constructing SRTs (see SRT.lhs).
99 A top-level Id has CafInfo, which is
101 - MayHaveCafRefs, if it may refer indirectly to
103 - NoCafRefs if it definitely doesn't
105 The CafInfo has already been calculated during the CoreTidy pass.
107 During CoreToStg, we then pin onto each binding and case expression, a
108 list of Ids which represents the "live" CAFs at that point. The meaning
109 of "live" here is the same as for live variables, see above (which is
110 why it's convenient to collect CAF information here rather than elsewhere).
112 The later SRT pass takes these lists of Ids and uses them to construct
113 the actual nested SRTs, and replaces the lists of Ids with (offset,length)
117 Interaction of let-no-escape with SRTs [Sept 01]
118 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
121 let-no-escape x = ...caf1...caf2...
125 where caf1,caf2 are CAFs. Since x doesn't have a closure, we
126 build SRTs just as if x's defn was inlined at each call site, and
127 that means that x's CAF refs get duplicated in the overall SRT.
129 This is unlike ordinary lets, in which the CAF refs are not duplicated.
131 We could fix this loss of (static) sharing by making a sort of pseudo-closure
132 for x, solely to put in the SRTs lower down.
135 %************************************************************************
137 \subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
139 %************************************************************************
142 coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
143 coreToStg this_pkg pgm
145 where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
147 coreExprToStg :: CoreExpr -> StgExpr
149 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
154 -> IdEnv HowBound -- environment for the bindings
156 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
158 coreTopBindsToStg _ env [] = (env, emptyFVInfo, [])
159 coreTopBindsToStg this_pkg env (b:bs)
160 = (env2, fvs2, b':bs')
162 -- Notice the mutually-recursive "knot" here:
163 -- env accumulates down the list of binds,
164 -- fvs accumulates upwards
165 (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
166 (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
171 -> FreeVarsInfo -- Info about the body
173 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
175 coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
177 env' = extendVarEnv env id how_bound
178 how_bound = LetBound TopLet $! manifestArity rhs
182 (stg_rhs, fvs') <- coreToTopStgRhs this_pkg body_fvs (id,rhs)
183 return (stg_rhs, fvs')
185 bind = StgNonRec id stg_rhs
187 ASSERT2(consistentCafInfo id bind, ppr id {- $$ ppr rhs $$ ppr bind -} )
188 (env', fvs' `unionFVInfo` body_fvs, bind)
190 coreTopBindToStg this_pkg env body_fvs (Rec pairs)
191 = ASSERT( not (null pairs) )
193 binders = map fst pairs
195 extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
196 | (b, rhs) <- pairs ]
197 env' = extendVarEnvList env extra_env'
201 (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs this_pkg body_fvs) pairs
202 let fvs' = unionFVInfos fvss'
203 return (stg_rhss, fvs')
205 bind = StgRec (zip binders stg_rhss)
207 ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
208 (env', fvs' `unionFVInfo` body_fvs, bind)
211 -- Assertion helper: this checks that the CafInfo on the Id matches
212 -- what CoreToStg has figured out about the binding's SRT. The
213 -- CafInfo will be exact in all cases except when CorePrep has
214 -- floated out a binding, in which case it will be approximate.
215 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
216 consistentCafInfo id bind
217 = WARN( not (exact || is_sat_thing) , ppr id )
220 safe = id_marked_caffy || not binding_is_caffy
221 exact = id_marked_caffy == binding_is_caffy
222 id_marked_caffy = mayHaveCafRefs (idCafInfo id)
223 binding_is_caffy = stgBindHasCafRefs bind
224 is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
230 -> FreeVarsInfo -- Free var info for the scope of the binding
232 -> LneM (StgRhs, FreeVarsInfo)
234 coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
235 = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
236 ; lv_info <- freeVarsToLiveVars rhs_fvs
238 ; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs
239 stg_arity = stgRhsArity stg_rhs
240 ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
243 bndr_info = lookupFVInfo scope_fv_info bndr
245 -- It's vital that the arity on a top-level Id matches
246 -- the arity of the generated STG binding, else an importing
247 -- module will use the wrong calling convention
248 -- (Trac #2844 was an example where this happened)
249 -- NB1: we can't move the assertion further out without
250 -- blocking the "knot" tied in coreTopBindsToStg
251 -- NB2: the arity check is only needed for Ids with External
252 -- Names, because they are externally visible. The CorePrep
253 -- pass introduces "sat" things with Local Names and does
254 -- not bother to set their Arity info, so don't fail for those
256 | isExternalName (idName bndr) = id_arity == stg_arity
258 id_arity = idArity bndr
259 mk_arity_msg stg_arity
261 ptext (sLit "Id arity:") <+> ppr id_arity,
262 ptext (sLit "STG arity:") <+> ppr stg_arity]
264 mkTopStgRhs :: PackageId -> FreeVarsInfo
265 -> SRT -> StgBinderInfo -> StgExpr
268 mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body)
269 = StgRhsClosure noCCS binder_info
275 mkTopStgRhs this_pkg _ _ _ (StgConApp con args)
276 | not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable
277 = StgRhsCon noCCS con args
279 mkTopStgRhs _ rhs_fvs srt binder_info rhs
280 = StgRhsClosure noCCS binder_info
288 -- ---------------------------------------------------------------------------
290 -- ---------------------------------------------------------------------------
295 -> LneM (StgExpr, -- Decorated STG expr
296 FreeVarsInfo, -- Its free vars (NB free, not live)
297 EscVarsSet) -- Its escapees, a subset of its free vars;
298 -- also a subset of the domain of the envt
299 -- because we are only interested in the escapees
300 -- for vars which might be turned into
301 -- let-no-escaped ones.
304 The second and third components can be derived in a simple bottom up pass, not
305 dependent on any decisions about which variables will be let-no-escaped or
306 not. The first component, that is, the decorated expression, may then depend
307 on these components, but it in turn is not scrutinised as the basis for any
308 decisions. Hence no black holes.
311 coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
312 coreToStgExpr (Var v) = coreToStgApp Nothing v []
314 coreToStgExpr expr@(App _ _)
315 = coreToStgApp Nothing f args
317 (f, args) = myCollectArgs expr
319 coreToStgExpr expr@(Lam _ _)
321 (args, body) = myCollectBinders expr
322 args' = filterStgBinders args
324 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
325 (body, body_fvs, body_escs) <- coreToStgExpr body
327 fvs = args' `minusFVBinders` body_fvs
328 escs = body_escs `delVarSetList` args'
329 result_expr | null args' = body
330 | otherwise = StgLam (exprType expr) args' body
332 return (result_expr, fvs, escs)
334 coreToStgExpr (Note (SCC cc) expr) = do
335 (expr2, fvs, escs) <- coreToStgExpr expr
336 return (StgSCC cc expr2, fvs, escs)
338 coreToStgExpr (Case (Var id) _bndr _ty [(DEFAULT,[],expr)])
339 | Just (TickBox m n) <- isTickBoxOp_maybe id = do
340 (expr2, fvs, escs) <- coreToStgExpr expr
341 return (StgTick m n expr2, fvs, escs)
343 coreToStgExpr (Note _ expr)
346 coreToStgExpr (Cast expr _)
349 -- Cases require a little more real work.
351 coreToStgExpr (Case scrut bndr _ alts) = do
352 (alts2, alts_fvs, alts_escs)
353 <- extendVarEnvLne [(bndr, LambdaBound)] $ do
354 (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
357 unionVarSets escs_s )
359 -- Determine whether the default binder is dead or not
360 -- This helps the code generator to avoid generating an assignment
361 -- for the case binder (is extremely rare cases) ToDo: remove.
362 bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
363 | otherwise = bndr `setIdOccInfo` IAmDead
365 -- Don't consider the default binder as being 'live in alts',
366 -- since this is from the point of view of the case expr, where
367 -- the default binder is not free.
368 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
369 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
371 alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
373 -- We tell the scrutinee that everything
374 -- live in the alts is live in it, too.
375 (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
376 <- setVarsLiveInCont alts_lv_info $ do
377 (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
378 scrut_lv_info <- freeVarsToLiveVars scrut_fvs
379 return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
382 StgCase scrut2 (getLiveVars scrut_lv_info)
383 (getLiveVars alts_lv_info)
386 (mkStgAltType bndr alts)
388 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
389 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
390 -- You might think we should have scrut_escs, not
391 -- (getFVSet scrut_fvs), but actually we can't call, and
392 -- then return from, a let-no-escape thing.
395 vars_alt (con, binders, rhs)
396 = let -- Remove type variables
397 binders' = filterStgBinders binders
399 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
400 (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
402 -- Records whether each param is used in the RHS
403 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
405 return ( (con, binders', good_use_mask, rhs2),
406 binders' `minusFVBinders` rhs_fvs,
407 rhs_escs `delVarSetList` binders' )
408 -- ToDo: remove the delVarSet;
409 -- since escs won't include any of these binders
412 Lets not only take quite a bit of work, but this is where we convert
413 then to let-no-escapes, if we wish.
415 (Meanwhile, we don't expect to see let-no-escapes...)
417 coreToStgExpr (Let bind body) = do
418 (new_let, fvs, escs, _)
419 <- mfix (\ ~(_, _, _, no_binder_escapes) ->
420 coreToStgLet no_binder_escapes bind body
423 return (new_let, fvs, escs)
425 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
429 mkStgAltType :: Id -> [CoreAlt] -> AltType
430 mkStgAltType bndr alts
431 = case splitTyConApp_maybe (repType (idType bndr)) of
432 Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc
433 | isUnLiftedTyCon tc -> PrimAlt tc
434 | isHiBootTyCon tc -> look_for_better_tycon
435 | isAlgTyCon tc -> AlgAlt tc
436 | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
441 _is_poly_alt_tycon tc
443 || isPrimTyCon tc -- "Any" is lifted but primitive
444 || isFamilyTyCon tc -- Type family; e.g. arising from strict
445 -- function application where argument has a
448 -- Sometimes, the TyCon is a HiBootTyCon which may not have any
449 -- constructors inside it. Then we can get a better TyCon by
450 -- grabbing the one from a constructor alternative
452 look_for_better_tycon
453 | ((DataAlt con, _, _) : _) <- data_alts =
454 AlgAlt (dataConTyCon con)
456 ASSERT(null data_alts)
459 (data_alts, _deflt) = findDefault alts
463 -- ---------------------------------------------------------------------------
465 -- ---------------------------------------------------------------------------
469 :: Maybe UpdateFlag -- Just upd <=> this application is
470 -- the rhs of a thunk binding
471 -- x = [...] \upd [] -> the_app
472 -- with specified update flag
474 -> [CoreArg] -- Arguments
475 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
478 coreToStgApp _ f args = do
479 (args', args_fvs) <- coreToStgArgs args
480 how_bound <- lookupVarLne f
483 n_val_args = valArgCount args
484 not_letrec_bound = not (isLetBound how_bound)
485 fun_fvs = singletonFVInfo f how_bound fun_occ
486 -- e.g. (f :: a -> int) (x :: a)
487 -- Here the free variables are "f", "x" AND the type variable "a"
488 -- coreToStgArgs will deal with the arguments recursively
490 -- Mostly, the arity info of a function is in the fn's IdInfo
491 -- But new bindings introduced by CoreSat may not have no
492 -- arity info; it would do us no good anyway. For example:
493 -- let f = \ab -> e in f
494 -- No point in having correct arity info for f!
495 -- Hence the hasArity stuff below.
496 -- NB: f_arity is only consulted for LetBound things
497 f_arity = stgArity f how_bound
498 saturated = f_arity <= n_val_args
501 | not_letrec_bound = noBinderInfo -- Uninteresting variable
502 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
503 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
506 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
507 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
508 -- saturated call doesn't escape
509 -- (let-no-escape applies to 'thunks' too)
511 | otherwise = unitVarSet f -- Inexact application; it does escape
513 -- At the moment of the call:
515 -- either the function is *not* let-no-escaped, in which case
516 -- nothing is live except live_in_cont
517 -- or the function *is* let-no-escaped in which case the
518 -- variables it uses are live, but still the function
519 -- itself is not. PS. In this case, the function's
520 -- live vars should already include those of the
521 -- continuation, but it does no harm to just union the
524 res_ty = exprType (mkApps (Var f) args)
525 app = case idDetails f of
526 DataConWorkId dc | saturated -> StgConApp dc args'
528 -- Some primitive operator that might be implemented as a library call.
529 PrimOpId op -> ASSERT( saturated )
530 StgOpApp (StgPrimOp op) args' res_ty
532 -- A call to some primitive Cmm function.
533 FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
534 -> ASSERT( saturated )
535 StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
537 -- A regular foreign call.
538 FCallId call -> ASSERT( saturated )
539 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
541 TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
542 _other -> StgApp f args'
546 fun_fvs `unionFVInfo` args_fvs,
547 fun_escs `unionVarSet` (getFVSet args_fvs)
548 -- All the free vars of the args are disqualified
549 -- from being let-no-escaped.
554 -- ---------------------------------------------------------------------------
556 -- This is the guy that turns applications into A-normal form
557 -- ---------------------------------------------------------------------------
559 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
561 = return ([], emptyFVInfo)
563 coreToStgArgs (Type _ : args) = do -- Type argument
564 (args', fvs) <- coreToStgArgs args
567 coreToStgArgs (arg : args) = do -- Non-type argument
568 (stg_args, args_fvs) <- coreToStgArgs args
569 (arg', arg_fvs, _escs) <- coreToStgExpr arg
571 fvs = args_fvs `unionFVInfo` arg_fvs
572 stg_arg = case arg' of
573 StgApp v [] -> StgVarArg v
574 StgConApp con [] -> StgVarArg (dataConWorkId con)
575 StgLit lit -> StgLitArg lit
576 _ -> pprPanic "coreToStgArgs" (ppr arg)
578 -- WARNING: what if we have an argument like (v `cast` co)
579 -- where 'co' changes the representation type?
580 -- (This really only happens if co is unsafe.)
581 -- Then all the getArgAmode stuff in CgBindery will set the
582 -- cg_rep of the CgIdInfo based on the type of v, rather
583 -- than the type of 'co'.
584 -- This matters particularly when the function is a primop
586 -- Wanted: a better solution than this hacky warning
588 arg_ty = exprType arg
589 stg_arg_ty = stgArgType stg_arg
590 bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
591 || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
592 -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
593 -- and pass it to a function expecting an HValue (arg_ty). This is ok because
594 -- we can treat an unlifted value as lifted. But the other way round
596 -- We also want to check if a pointer is cast to a non-ptr etc
598 WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
599 return (stg_arg : stg_args, fvs)
602 -- ---------------------------------------------------------------------------
603 -- The magic for lets:
604 -- ---------------------------------------------------------------------------
607 :: Bool -- True <=> yes, we are let-no-escaping this let
608 -> CoreBind -- bindings
610 -> LneM (StgExpr, -- new let
611 FreeVarsInfo, -- variables free in the whole let
612 EscVarsSet, -- variables that escape from the whole let
613 Bool) -- True <=> none of the binders in the bindings
614 -- is among the escaping vars
616 coreToStgLet let_no_escape bind body = do
617 (bind2, bind_fvs, bind_escs, bind_lvs,
618 body2, body_fvs, body_escs, body_lvs)
619 <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
621 -- Do the bindings, setting live_in_cont to empty if
622 -- we ain't in a let-no-escape world
623 live_in_cont <- getVarsLiveInCont
624 ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
625 <- setVarsLiveInCont (if let_no_escape
628 (vars_bind rec_body_fvs bind)
631 extendVarEnvLne env_ext $ do
632 (body2, body_fvs, body_escs) <- coreToStgExpr body
633 body_lv_info <- freeVarsToLiveVars body_fvs
635 return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
636 body2, body_fvs, body_escs, getLiveVars body_lv_info)
639 -- Compute the new let-expression
641 new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
642 | otherwise = StgLet bind2 body2
645 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
648 = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
650 real_bind_escs = if let_no_escape then
654 -- Everything escapes which is free in the bindings
656 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
658 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
661 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
663 -- Debugging code as requested by Andrew Kennedy
664 checked_no_binder_escapes
665 | debugIsOn && not no_binder_escapes && any is_join_var binders
666 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
668 | otherwise = no_binder_escapes
670 -- Mustn't depend on the passed-in let_no_escape flag, since
671 -- no_binder_escapes is used by the caller to derive the flag!
676 checked_no_binder_escapes
679 set_of_binders = mkVarSet binders
680 binders = bindersOf bind
682 mk_binding bind_lv_info binder rhs
683 = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
685 live_vars | let_no_escape = addLiveVar bind_lv_info binder
686 | otherwise = unitLiveVar binder
687 -- c.f. the invariant on NestedLet
689 vars_bind :: FreeVarsInfo -- Free var info for body of binding
693 EscVarsSet, -- free vars; escapee vars
694 LiveInfo, -- Vars and CAFs live in binding
695 [(Id, HowBound)]) -- extension to environment
698 vars_bind body_fvs (NonRec binder rhs) = do
699 (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
701 env_ext_item = mk_binding bind_lv_info binder rhs
703 return (StgNonRec binder rhs2,
704 bind_fvs, escs, bind_lv_info, [env_ext_item])
707 vars_bind body_fvs (Rec pairs)
708 = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
710 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
711 binders = map fst pairs
712 env_ext = [ mk_binding bind_lv_info b rhs
715 extendVarEnvLne env_ext $ do
716 (rhss2, fvss, lv_infos, escss)
717 <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
719 bind_fvs = unionFVInfos fvss
720 bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
721 escs = unionVarSets escss
723 return (StgRec (binders `zip` rhss2),
724 bind_fvs, escs, bind_lv_info, env_ext)
727 is_join_var :: Id -> Bool
728 -- A hack (used only for compiler debuggging) to tell if
729 -- a variable started life as a join point ($j)
730 is_join_var j = occNameString (getOccName j) == "$j"
734 coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
737 -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
739 coreToStgRhs scope_fv_info binders (bndr, rhs) = do
740 (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
741 lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
742 return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
743 rhs_fvs, lv_info, rhs_escs)
745 bndr_info = lookupFVInfo scope_fv_info bndr
747 mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
749 mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
751 mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body)
752 = StgRhsClosure noCCS binder_info
757 mkStgRhs rhs_fvs srt binder_info rhs
758 = StgRhsClosure noCCS binder_info
764 SDM: disabled. Eval/Apply can't handle functions with arity zero very
765 well; and making these into simple non-updatable thunks breaks other
766 assumptions (namely that they will be entered only once).
768 upd_flag | isPAP env rhs = ReEntrant
769 | otherwise = Updatable
773 upd = if isOnceDem dem
774 then (if isNotTop toplev
775 then SingleEntry -- HA! Paydirt for "dem"
778 trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
782 -- For now we forbid SingleEntry CAFs; they tickle the
783 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
784 -- and I don't understand why. There's only one SE_CAF (well,
785 -- only one that tickled a great gaping bug in an earlier attempt
786 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
787 -- specifically Main.lvl6 in spectral/cryptarithm2.
788 -- So no great loss. KSW 2000-07.
792 Detect thunks which will reduce immediately to PAPs, and make them
793 non-updatable. This has several advantages:
795 - the non-updatable thunk behaves exactly like the PAP,
797 - the thunk is more efficient to enter, because it is
798 specialised to the task.
800 - we save one update frame, one stg_update_PAP, one update
801 and lots of PAP_enters.
803 - in the case where the thunk is top-level, we save building
804 a black hole and futhermore the thunk isn't considered to
805 be a CAF any more, so it doesn't appear in any SRTs.
807 We do it here, because the arity information is accurate, and we need
808 to do it before the SRT pass to save the SRT entries associated with
811 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
813 arity = stgArity f (lookupBinding env f)
817 %************************************************************************
819 \subsection[LNE-monad]{A little monad for this let-no-escaping pass}
821 %************************************************************************
823 There's a lot of stuff to pass around, so we use this @LneM@ monad to
824 help. All the stuff here is only passed *down*.
827 newtype LneM a = LneM
828 { unLneM :: IdEnv HowBound
829 -> LiveInfo -- Vars and CAFs live in continuation
833 type LiveInfo = (StgLiveVars, -- Dynamic live variables;
834 -- i.e. ones with a nested (non-top-level) binding
835 CafSet) -- Static live variables;
836 -- i.e. top-level variables that are CAFs or refer to them
838 type EscVarsSet = IdSet
842 = ImportBound -- Used only as a response to lookupBinding; never
843 -- exists in the range of the (IdEnv HowBound)
845 | LetBound -- A let(rec) in this module
846 LetInfo -- Whether top level or nested
847 Arity -- Its arity (local Ids don't have arity info at this point)
849 | LambdaBound -- Used for both lambda and case
852 = TopLet -- top level things
853 | NestedLet LiveInfo -- For nested things, what is live if this
854 -- thing is live? Invariant: the binder
855 -- itself is always a member of
856 -- the dynamic set of its own LiveInfo
858 isLetBound :: HowBound -> Bool
859 isLetBound (LetBound _ _) = True
862 topLevelBound :: HowBound -> Bool
863 topLevelBound ImportBound = True
864 topLevelBound (LetBound TopLet _) = True
865 topLevelBound _ = False
868 For a let(rec)-bound variable, x, we record LiveInfo, the set of
869 variables that are live if x is live. This LiveInfo comprises
870 (a) dynamic live variables (ones with a non-top-level binding)
871 (b) static live variabes (CAFs or things that refer to CAFs)
873 For "normal" variables (a) is just x alone. If x is a let-no-escaped
874 variable then x is represented by a code pointer and a stack pointer
875 (well, one for each stack). So all of the variables needed in the
876 execution of x are live if x is, and are therefore recorded in the
877 LetBound constructor; x itself *is* included.
879 The set of dynamic live variables is guaranteed ot have no further let-no-escaped
883 emptyLiveInfo :: LiveInfo
884 emptyLiveInfo = (emptyVarSet,emptyVarSet)
886 unitLiveVar :: Id -> LiveInfo
887 unitLiveVar lv = (unitVarSet lv, emptyVarSet)
889 unitLiveCaf :: Id -> LiveInfo
890 unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
892 addLiveVar :: LiveInfo -> Id -> LiveInfo
893 addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
895 unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
896 unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
898 mkSRT :: LiveInfo -> SRT
899 mkSRT (_, cafs) = SRTEntries cafs
901 getLiveVars :: LiveInfo -> StgLiveVars
902 getLiveVars (lvs, _) = lvs
906 The std monad functions:
908 initLne :: IdEnv HowBound -> LneM a -> a
909 initLne env m = unLneM m env emptyLiveInfo
913 {-# INLINE thenLne #-}
914 {-# INLINE returnLne #-}
916 returnLne :: a -> LneM a
917 returnLne e = LneM $ \_ _ -> e
919 thenLne :: LneM a -> (a -> LneM b) -> LneM b
920 thenLne m k = LneM $ \env lvs_cont
921 -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
923 instance Monad LneM where
927 instance MonadFix LneM where
928 mfix expr = LneM $ \env lvs_cont ->
929 let result = unLneM (expr result) env lvs_cont
933 Functions specific to this monad:
936 getVarsLiveInCont :: LneM LiveInfo
937 getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
939 setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
940 setVarsLiveInCont new_lvs_cont expr
941 = LneM $ \env _lvs_cont
942 -> unLneM expr env new_lvs_cont
944 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
945 extendVarEnvLne ids_w_howbound expr
946 = LneM $ \env lvs_cont
947 -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
949 lookupVarLne :: Id -> LneM HowBound
950 lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
952 lookupBinding :: IdEnv HowBound -> Id -> HowBound
953 lookupBinding env v = case lookupVarEnv env v of
955 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
958 -- The result of lookupLiveVarsForSet, a set of live variables, is
959 -- only ever tacked onto a decorated expression. It is never used as
960 -- the basis of a control decision, which might give a black hole.
962 freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
963 freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
965 freeVarsToLiveVars' _env live_in_cont = live_info
967 live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
968 lvs_from_fvs = map do_one (allFreeIds fvs)
970 do_one (v, how_bound)
972 ImportBound -> unitLiveCaf v -- Only CAF imports are
975 | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
976 | otherwise -> emptyLiveInfo
978 LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
979 -- (see the invariant on NestedLet)
981 _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
984 %************************************************************************
986 \subsection[Free-var info]{Free variable information}
988 %************************************************************************
991 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
992 -- The Var is so we can gather up the free variables
995 -- The HowBound info just saves repeated lookups;
996 -- we look up just once when we encounter the occurrence.
997 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
998 -- Imported Ids without CAF refs are simply
999 -- not put in the FreeVarsInfo for an expression.
1000 -- See singletonFVInfo and freeVarsToLiveVars
1002 -- StgBinderInfo records how it occurs; notably, we
1003 -- are interested in whether it only occurs in saturated
1004 -- applications, because then we don't need to build a
1006 -- If f is mapped to noBinderInfo, that means
1007 -- that f *is* mentioned (else it wouldn't be in the
1008 -- IdEnv at all), but perhaps in an unsaturated applications.
1010 -- All case/lambda-bound things are also mapped to
1011 -- noBinderInfo, since we aren't interested in their
1014 -- For ILX we track free var info for type variables too;
1015 -- hence VarEnv not IdEnv
1019 emptyFVInfo :: FreeVarsInfo
1020 emptyFVInfo = emptyVarEnv
1022 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
1023 -- Don't record non-CAF imports at all, to keep free-var sets small
1024 singletonFVInfo id ImportBound info
1025 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
1026 | otherwise = emptyVarEnv
1027 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
1029 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
1030 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
1032 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
1033 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
1035 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
1036 minusFVBinders vs fv = foldr minusFVBinder fv vs
1038 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
1039 minusFVBinder v fv = fv `delVarEnv` v
1040 -- When removing a binder, remember to add its type variables
1041 -- c.f. CoreFVs.delBinderFV
1043 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
1044 elementOfFVInfo id fvs = maybeToBool (lookupVarEnv fvs id)
1046 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
1047 -- Find how the given Id is used.
1048 -- Externally visible things may be used any old how
1050 | isExternalName (idName id) = noBinderInfo
1051 | otherwise = case lookupVarEnv fvs id of
1052 Nothing -> noBinderInfo
1053 Just (_,_,info) -> info
1055 allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
1056 allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
1058 ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
1060 -- Non-top-level things only, both type variables and ids
1061 getFVs :: FreeVarsInfo -> [Var]
1062 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
1063 not (topLevelBound how_bound) ]
1065 getFVSet :: FreeVarsInfo -> VarSet
1066 getFVSet fvs = mkVarSet (getFVs fvs)
1068 plusFVInfo :: (Var, HowBound, StgBinderInfo)
1069 -> (Var, HowBound, StgBinderInfo)
1070 -> (Var, HowBound, StgBinderInfo)
1071 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1072 = ASSERT (id1 == id2 && hb1 `check_eq_how_bound` hb2)
1073 (id1, hb1, combineStgBinderInfo info1 info2)
1075 -- The HowBound info for a variable in the FVInfo should be consistent
1076 check_eq_how_bound :: HowBound -> HowBound -> Bool
1077 check_eq_how_bound ImportBound ImportBound = True
1078 check_eq_how_bound LambdaBound LambdaBound = True
1079 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1080 check_eq_how_bound _ _ = False
1082 check_eq_li :: LetInfo -> LetInfo -> Bool
1083 check_eq_li (NestedLet _) (NestedLet _) = True
1084 check_eq_li TopLet TopLet = True
1085 check_eq_li _ _ = False
1090 filterStgBinders :: [Var] -> [Var]
1091 filterStgBinders bndrs = filter isId bndrs
1096 -- Ignore all notes except SCC
1097 myCollectBinders :: Expr Var -> ([Var], Expr Var)
1098 myCollectBinders expr
1101 go bs (Lam b e) = go (b:bs) e
1102 go bs e@(Note (SCC _) _) = (reverse bs, e)
1103 go bs (Cast e _) = go bs e
1104 go bs (Note _ e) = go bs e
1105 go bs e = (reverse bs, e)
1107 myCollectArgs :: CoreExpr -> (Id, [CoreArg])
1108 -- We assume that we only have variables
1109 -- in the function position by now
1113 go (Var v) as = (v, as)
1114 go (App f a) as = go f (a:as)
1115 go (Note (SCC _) _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1116 go (Cast e _) as = go e as
1117 go (Note _ e) as = go e as
1119 | isTyCoVar b = go e as -- Note [Collect args]
1120 go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1125 This big-lambda case occurred following a rather obscure eta expansion.
1126 It all seems a bit yukky to me.
1129 stgArity :: Id -> HowBound -> Arity
1130 stgArity _ (LetBound _ arity) = arity
1131 stgArity f ImportBound = idArity f
1132 stgArity _ LambdaBound = 0