Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape
[ghc.git] / compiler / stgSyn / CoreToStg.hs
1 {-# LANGUAGE CPP #-}
2
3 --
4 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
5 --
6
7 --------------------------------------------------------------
8 -- Converting Core to STG Syntax
9 --------------------------------------------------------------
10
11 -- And, as we have the info in hand, we may convert some lets to
12 -- let-no-escapes.
13
14 module CoreToStg ( coreToStg, coreExprToStg ) where
15
16 #include "HsVersions.h"
17
18 import CoreSyn
19 import CoreUtils ( exprType, findDefault )
20 import CoreArity ( manifestArity )
21 import StgSyn
22
23 import Type
24 import TyCon
25 import MkId ( coercionTokenId )
26 import Id
27 import IdInfo
28 import DataCon
29 import CostCentre ( noCCS )
30 import VarSet
31 import VarEnv
32 import Module
33 import Name ( getOccName, isExternalName, nameOccName )
34 import OccName ( occNameString, occNameFS )
35 import BasicTypes ( Arity )
36 import TysWiredIn ( unboxedUnitDataCon )
37 import Literal
38 import Outputable
39 import MonadUtils
40 import FastString
41 import Util
42 import DynFlags
43 import ForeignCall
44 import Demand ( isUsedOnce )
45 import PrimOp ( PrimCall(..) )
46
47 import Data.Maybe (isJust)
48 import Control.Monad (liftM, ap)
49
50 -- Note [Live vs free]
51 -- ~~~~~~~~~~~~~~~~~~~
52 --
53 -- The two are not the same. Liveness is an operational property rather
54 -- than a semantic one. A variable is live at a particular execution
55 -- point if it can be referred to directly again. In particular, a dead
56 -- variable's stack slot (if it has one):
57 --
58 -- - should be stubbed to avoid space leaks, and
59 -- - may be reused for something else.
60 --
61 -- There ought to be a better way to say this. Here are some examples:
62 --
63 -- let v = [q] \[x] -> e
64 -- in
65 -- ...v... (but no q's)
66 --
67 -- Just after the `in', v is live, but q is dead. If the whole of that
68 -- let expression was enclosed in a case expression, thus:
69 --
70 -- case (let v = [q] \[x] -> e in ...v...) of
71 -- alts[...q...]
72 --
73 -- (ie `alts' mention `q'), then `q' is live even after the `in'; because
74 -- we'll return later to the `alts' and need it.
75 --
76 -- Let-no-escapes make this a bit more interesting:
77 --
78 -- let-no-escape v = [q] \ [x] -> e
79 -- in
80 -- ...v...
81 --
82 -- Here, `q' is still live at the `in', because `v' is represented not by
83 -- a closure but by the current stack state. In other words, if `v' is
84 -- live then so is `q'. Furthermore, if `e' mentions an enclosing
85 -- let-no-escaped variable, then its free variables are also live if `v' is.
86
87 -- Note [Collecting live CAF info]
88 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
89 --
90 -- In this pass we also collect information on which CAFs are live.
91 --
92 -- A top-level Id has CafInfo, which is
93 --
94 -- - MayHaveCafRefs, if it may refer indirectly to
95 -- one or more CAFs, or
96 -- - NoCafRefs if it definitely doesn't
97 --
98 -- The CafInfo has already been calculated during the CoreTidy pass.
99 --
100 -- During CoreToStg, we then pin onto each binding and case expression, a
101 -- list of Ids which represents the "live" CAFs at that point. The meaning
102 -- of "live" here is the same as for live variables, see above (which is
103 -- why it's convenient to collect CAF information here rather than elsewhere).
104 --
105 -- The later SRT pass takes these lists of Ids and uses them to construct
106 -- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
107 -- pairs.
108
109 -- Note [What is a non-escaping let]
110 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
111 --
112 -- Consider:
113 --
114 -- let x = fvs \ args -> e
115 -- in
116 -- if ... then x else
117 -- if ... then x else ...
118 --
119 -- `x' is used twice (so we probably can't unfold it), but when it is
120 -- entered, the stack is deeper than it was when the definition of `x'
121 -- happened. Specifically, if instead of allocating a closure for `x',
122 -- we saved all `x's fvs on the stack, and remembered the stack depth at
123 -- that moment, then whenever we enter `x' we can simply set the stack
124 -- pointer(s) to these remembered (compile-time-fixed) values, and jump
125 -- to the code for `x'.
126 --
127 -- All of this is provided x is:
128 -- 1. non-updatable - it must have at least one parameter (see Note
129 -- [Join point abstraction]);
130 -- 2. guaranteed to be entered before the stack retreats -- ie x is not
131 -- buried in a heap-allocated closure, or passed as an argument to
132 -- something;
133 -- 3. all the enters have exactly the right number of arguments,
134 -- no more no less;
135 -- 4. all the enters are tail calls; that is, they return to the
136 -- caller enclosing the definition of `x'.
137 --
138 -- Under these circumstances we say that `x' is non-escaping.
139 --
140 -- An example of when (4) does not hold:
141 --
142 -- let x = ...
143 -- in case x of ...alts...
144 --
145 -- Here, `x' is certainly entered only when the stack is deeper than when
146 -- `x' is defined, but here it must return to ...alts... So we can't just
147 -- adjust the stack down to `x''s recalled points, because that would lost
148 -- alts' context.
149 --
150 -- Things can get a little more complicated. Consider:
151 --
152 -- let y = ...
153 -- in let x = fvs \ args -> ...y...
154 -- in ...x...
155 --
156 -- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
157 -- non-escaping way in ...y..., then `y' is non-escaping.
158 --
159 -- `x' can even be recursive! Eg:
160 --
161 -- letrec x = [y] \ [v] -> if v then x True else ...
162 -- in
163 -- ...(x b)...
164
165 -- --------------------------------------------------------------
166 -- Setting variable info: top-level, binds, RHSs
167 -- --------------------------------------------------------------
168
169 coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
170 coreToStg dflags this_mod pgm
171 = pgm'
172 where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
173
174 coreExprToStg :: CoreExpr -> StgExpr
175 coreExprToStg expr
176 = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
177
178
179 coreTopBindsToStg
180 :: DynFlags
181 -> Module
182 -> IdEnv HowBound -- environment for the bindings
183 -> CoreProgram
184 -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
185
186 coreTopBindsToStg _ _ env [] = (env, emptyFVInfo, [])
187 coreTopBindsToStg dflags this_mod env (b:bs)
188 = (env2, fvs2, b':bs')
189 where
190 -- Notice the mutually-recursive "knot" here:
191 -- env accumulates down the list of binds,
192 -- fvs accumulates upwards
193 (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
194 (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
195
196 coreTopBindToStg
197 :: DynFlags
198 -> Module
199 -> IdEnv HowBound
200 -> FreeVarsInfo -- Info about the body
201 -> CoreBind
202 -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
203
204 coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
205 = let
206 env' = extendVarEnv env id how_bound
207 how_bound = LetBound TopLet $! manifestArity rhs
208
209 (stg_rhs, fvs') =
210 initLne env $ do
211 (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
212 return (stg_rhs, fvs')
213
214 bind = StgNonRec id stg_rhs
215 in
216 ASSERT2(consistentCafInfo id bind, ppr id )
217 -- NB: previously the assertion printed 'rhs' and 'bind'
218 -- as well as 'id', but that led to a black hole
219 -- where printing the assertion error tripped the
220 -- assertion again!
221 (env', fvs' `unionFVInfo` body_fvs, bind)
222
223 coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
224 = ASSERT( not (null pairs) )
225 let
226 binders = map fst pairs
227
228 extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
229 | (b, rhs) <- pairs ]
230 env' = extendVarEnvList env extra_env'
231
232 (stg_rhss, fvs')
233 = initLne env' $ do
234 (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
235 let fvs' = unionFVInfos fvss'
236 return (stg_rhss, fvs')
237
238 bind = StgRec (zip binders stg_rhss)
239 in
240 ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
241 (env', fvs' `unionFVInfo` body_fvs, bind)
242
243
244 -- Assertion helper: this checks that the CafInfo on the Id matches
245 -- what CoreToStg has figured out about the binding's SRT. The
246 -- CafInfo will be exact in all cases except when CorePrep has
247 -- floated out a binding, in which case it will be approximate.
248 consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
249 consistentCafInfo id bind
250 = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
251 safe
252 where
253 safe = id_marked_caffy || not binding_is_caffy
254 exact = id_marked_caffy == binding_is_caffy
255 id_marked_caffy = mayHaveCafRefs (idCafInfo id)
256 binding_is_caffy = stgBindHasCafRefs bind
257 is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
258
259 coreToTopStgRhs
260 :: DynFlags
261 -> Module
262 -> FreeVarsInfo -- Free var info for the scope of the binding
263 -> (Id,CoreExpr)
264 -> LneM (StgRhs, FreeVarsInfo)
265
266 coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
267 = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
268
269 ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
270 stg_arity = stgRhsArity stg_rhs
271 ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
272 rhs_fvs) }
273 where
274 bndr_info = lookupFVInfo scope_fv_info bndr
275
276 -- It's vital that the arity on a top-level Id matches
277 -- the arity of the generated STG binding, else an importing
278 -- module will use the wrong calling convention
279 -- (Trac #2844 was an example where this happened)
280 -- NB1: we can't move the assertion further out without
281 -- blocking the "knot" tied in coreTopBindsToStg
282 -- NB2: the arity check is only needed for Ids with External
283 -- Names, because they are externally visible. The CorePrep
284 -- pass introduces "sat" things with Local Names and does
285 -- not bother to set their Arity info, so don't fail for those
286 arity_ok stg_arity
287 | isExternalName (idName bndr) = id_arity == stg_arity
288 | otherwise = True
289 id_arity = idArity bndr
290 mk_arity_msg stg_arity
291 = vcat [ppr bndr,
292 text "Id arity:" <+> ppr id_arity,
293 text "STG arity:" <+> ppr stg_arity]
294
295 mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
296 -> Id -> StgBinderInfo -> StgExpr
297 -> StgRhs
298
299 mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
300 -- Dynamic StgConApps are updatable
301 where con_updateable con args = isDllConApp dflags this_mod con args
302
303 -- ---------------------------------------------------------------------------
304 -- Expressions
305 -- ---------------------------------------------------------------------------
306
307 coreToStgExpr
308 :: CoreExpr
309 -> LneM (StgExpr, -- Decorated STG expr
310 FreeVarsInfo, -- Its free vars (NB free, not live)
311 EscVarsSet) -- Its escapees, a subset of its free vars;
312 -- also a subset of the domain of the envt
313 -- because we are only interested in the escapees
314 -- for vars which might be turned into
315 -- let-no-escaped ones.
316
317 -- The second and third components can be derived in a simple bottom up pass, not
318 -- dependent on any decisions about which variables will be let-no-escaped or
319 -- not. The first component, that is, the decorated expression, may then depend
320 -- on these components, but it in turn is not scrutinised as the basis for any
321 -- decisions. Hence no black holes.
322
323 -- No LitInteger's should be left by the time this is called. CorePrep
324 -- should have converted them all to a real core representation.
325 coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
326 coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
327 coreToStgExpr (Var v) = coreToStgApp Nothing v [] []
328 coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
329
330 coreToStgExpr expr@(App _ _)
331 = coreToStgApp Nothing f args ticks
332 where
333 (f, args, ticks) = myCollectArgs expr
334
335 coreToStgExpr expr@(Lam _ _)
336 = let
337 (args, body) = myCollectBinders expr
338 args' = filterStgBinders args
339 in
340 extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
341 (body, body_fvs, body_escs) <- coreToStgExpr body
342 let
343 fvs = args' `minusFVBinders` body_fvs
344 escs = body_escs `delVarSetList` args'
345 result_expr | null args' = body
346 | otherwise = StgLam args' body
347
348 return (result_expr, fvs, escs)
349
350 coreToStgExpr (Tick tick expr)
351 = do case tick of
352 HpcTick{} -> return ()
353 ProfNote{} -> return ()
354 SourceNote{} -> return ()
355 Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
356 (expr2, fvs, escs) <- coreToStgExpr expr
357 return (StgTick tick expr2, fvs, escs)
358
359 coreToStgExpr (Cast expr _)
360 = coreToStgExpr expr
361
362 -- Cases require a little more real work.
363
364 coreToStgExpr (Case scrut _ _ [])
365 = coreToStgExpr scrut
366 -- See Note [Empty case alternatives] in CoreSyn If the case
367 -- alternatives are empty, the scrutinee must diverge or raise an
368 -- exception, so we can just dive into it.
369 --
370 -- Of course this may seg-fault if the scrutinee *does* return. A
371 -- belt-and-braces approach would be to move this case into the
372 -- code generator, and put a return point anyway that calls a
373 -- runtime system error function.
374
375
376 coreToStgExpr (Case scrut bndr _ alts) = do
377 (alts2, alts_fvs, alts_escs)
378 <- extendVarEnvLne [(bndr, LambdaBound)] $ do
379 (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
380 return ( alts2,
381 unionFVInfos fvs_s,
382 unionVarSets escs_s )
383 let
384 -- Determine whether the default binder is dead or not
385 -- This helps the code generator to avoid generating an assignment
386 -- for the case binder (is extremely rare cases) ToDo: remove.
387 bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
388 | otherwise = bndr `setIdOccInfo` IAmDead
389
390 -- Don't consider the default binder as being 'live in alts',
391 -- since this is from the point of view of the case expr, where
392 -- the default binder is not free.
393 alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
394 alts_escs_wo_bndr = alts_escs `delVarSet` bndr
395
396 -- We tell the scrutinee that everything
397 -- live in the alts is live in it, too.
398 (scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
399
400 return (
401 StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
402 scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
403 alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
404 -- You might think we should have scrut_escs, not
405 -- (getFVSet scrut_fvs), but actually we can't call, and
406 -- then return from, a let-no-escape thing.
407 )
408 where
409 vars_alt (con, binders, rhs)
410 | DataAlt c <- con, c == unboxedUnitDataCon
411 = -- This case is a bit smelly.
412 -- See Note [Nullary unboxed tuple] in Type.hs
413 -- where a nullary tuple is mapped to (State# World#)
414 ASSERT( null binders )
415 do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
416 ; return ((DEFAULT, [], [], rhs2), rhs_fvs, rhs_escs) }
417 | otherwise
418 = let -- Remove type variables
419 binders' = filterStgBinders binders
420 in
421 extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
422 (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
423 let
424 -- Records whether each param is used in the RHS
425 good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
426
427 return ( (con, binders', good_use_mask, rhs2),
428 binders' `minusFVBinders` rhs_fvs,
429 rhs_escs `delVarSetList` binders' )
430 -- ToDo: remove the delVarSet;
431 -- since escs won't include any of these binders
432
433 -- Lets not only take quite a bit of work, but this is where we convert
434 -- then to let-no-escapes, if we wish.
435 -- (Meanwhile, we don't expect to see let-no-escapes...)
436
437
438 coreToStgExpr (Let bind body) = do
439 (new_let, fvs, escs, _)
440 <- mfix (\ ~(_, _, _, no_binder_escapes) ->
441 coreToStgLet no_binder_escapes bind body
442 )
443
444 return (new_let, fvs, escs)
445
446 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
447
448 mkStgAltType :: Id -> [CoreAlt] -> AltType
449 mkStgAltType bndr alts = case repType (idType bndr) of
450 UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
451 Just tc | isUnliftedTyCon tc -> PrimAlt tc
452 | isAbstractTyCon tc -> look_for_better_tycon
453 | isAlgTyCon tc -> AlgAlt tc
454 | otherwise -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
455 PolyAlt
456 Nothing -> PolyAlt
457 UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys)
458 -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt
459 where
460 _is_poly_alt_tycon tc
461 = isFunTyCon tc
462 || isPrimTyCon tc -- "Any" is lifted but primitive
463 || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
464 -- function application where argument has a
465 -- type-family type
466
467 -- Sometimes, the TyCon is a AbstractTyCon which may not have any
468 -- constructors inside it. Then we may get a better TyCon by
469 -- grabbing the one from a constructor alternative
470 -- if one exists.
471 look_for_better_tycon
472 | ((DataAlt con, _, _) : _) <- data_alts =
473 AlgAlt (dataConTyCon con)
474 | otherwise =
475 ASSERT(null data_alts)
476 PolyAlt
477 where
478 (data_alts, _deflt) = findDefault alts
479
480 -- ---------------------------------------------------------------------------
481 -- Applications
482 -- ---------------------------------------------------------------------------
483
484 coreToStgApp
485 :: Maybe UpdateFlag -- Just upd <=> this application is
486 -- the rhs of a thunk binding
487 -- x = [...] \upd [] -> the_app
488 -- with specified update flag
489 -> Id -- Function
490 -> [CoreArg] -- Arguments
491 -> [Tickish Id] -- Debug ticks
492 -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
493
494
495 coreToStgApp _ f args ticks = do
496 (args', args_fvs, ticks') <- coreToStgArgs args
497 how_bound <- lookupVarLne f
498
499 let
500 n_val_args = valArgCount args
501 not_letrec_bound = not (isLetBound how_bound)
502 fun_fvs = singletonFVInfo f how_bound fun_occ
503 -- e.g. (f :: a -> int) (x :: a)
504 -- Here the free variables are "f", "x" AND the type variable "a"
505 -- coreToStgArgs will deal with the arguments recursively
506
507 -- Mostly, the arity info of a function is in the fn's IdInfo
508 -- But new bindings introduced by CoreSat may not have no
509 -- arity info; it would do us no good anyway. For example:
510 -- let f = \ab -> e in f
511 -- No point in having correct arity info for f!
512 -- Hence the hasArity stuff below.
513 -- NB: f_arity is only consulted for LetBound things
514 f_arity = stgArity f how_bound
515 saturated = f_arity <= n_val_args
516
517 fun_occ
518 | not_letrec_bound = noBinderInfo -- Uninteresting variable
519 | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
520 | otherwise = stgUnsatOcc -- Unsaturated function or thunk
521
522 fun_escs
523 | not_letrec_bound = emptyVarSet -- Only letrec-bound escapees are interesting
524 | f_arity == n_val_args = emptyVarSet -- A function *or thunk* with an exactly
525 -- saturated call doesn't escape
526 -- (let-no-escape applies to 'thunks' too)
527
528 | otherwise = unitVarSet f -- Inexact application; it does escape
529
530 -- At the moment of the call:
531
532 -- either the function is *not* let-no-escaped, in which case
533 -- nothing is live except live_in_cont
534 -- or the function *is* let-no-escaped in which case the
535 -- variables it uses are live, but still the function
536 -- itself is not. PS. In this case, the function's
537 -- live vars should already include those of the
538 -- continuation, but it does no harm to just union the
539 -- two regardless.
540
541 res_ty = exprType (mkApps (Var f) args)
542 app = case idDetails f of
543 DataConWorkId dc | saturated -> StgConApp dc args'
544
545 -- Some primitive operator that might be implemented as a library call.
546 PrimOpId op -> ASSERT( saturated )
547 StgOpApp (StgPrimOp op) args' res_ty
548
549 -- A call to some primitive Cmm function.
550 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
551 PrimCallConv _))
552 -> ASSERT( saturated )
553 StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
554
555 -- A regular foreign call.
556 FCallId call -> ASSERT( saturated )
557 StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
558
559 TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
560 _other -> StgApp f args'
561 fvs = fun_fvs `unionFVInfo` args_fvs
562 vars = fun_escs `unionVarSet` (getFVSet args_fvs)
563 -- All the free vars of the args are disqualified
564 -- from being let-no-escaped.
565
566 tapp = foldr StgTick app (ticks ++ ticks')
567
568 -- Forcing these fixes a leak in the code generator, noticed while
569 -- profiling for trac #4367
570 app `seq` fvs `seq` seqVarSet vars `seq` return (
571 tapp,
572 fvs,
573 vars
574 )
575
576
577
578 -- ---------------------------------------------------------------------------
579 -- Argument lists
580 -- This is the guy that turns applications into A-normal form
581 -- ---------------------------------------------------------------------------
582
583 coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo, [Tickish Id])
584 coreToStgArgs []
585 = return ([], emptyFVInfo, [])
586
587 coreToStgArgs (Type _ : args) = do -- Type argument
588 (args', fvs, ts) <- coreToStgArgs args
589 return (args', fvs, ts)
590
591 coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
592 = do { (args', fvs, ts) <- coreToStgArgs args
593 ; return (StgVarArg coercionTokenId : args', fvs, ts) }
594
595 coreToStgArgs (Tick t e : args)
596 = ASSERT( not (tickishIsCode t) )
597 do { (args', fvs, ts) <- coreToStgArgs (e : args)
598 ; return (args', fvs, t:ts) }
599
600 coreToStgArgs (arg : args) = do -- Non-type argument
601 (stg_args, args_fvs, ticks) <- coreToStgArgs args
602 (arg', arg_fvs, _escs) <- coreToStgExpr arg
603 let
604 fvs = args_fvs `unionFVInfo` arg_fvs
605
606 (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
607 stg_arg = case arg'' of
608 StgApp v [] -> StgVarArg v
609 StgConApp con [] -> StgVarArg (dataConWorkId con)
610 StgLit lit -> StgLitArg lit
611 _ -> pprPanic "coreToStgArgs" (ppr arg)
612
613 -- WARNING: what if we have an argument like (v `cast` co)
614 -- where 'co' changes the representation type?
615 -- (This really only happens if co is unsafe.)
616 -- Then all the getArgAmode stuff in CgBindery will set the
617 -- cg_rep of the CgIdInfo based on the type of v, rather
618 -- than the type of 'co'.
619 -- This matters particularly when the function is a primop
620 -- or foreign call.
621 -- Wanted: a better solution than this hacky warning
622 let
623 arg_ty = exprType arg
624 stg_arg_ty = stgArgType stg_arg
625 bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
626 || (map typePrimRep (flattenRepType (repType arg_ty))
627 /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
628 -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
629 -- and pass it to a function expecting an HValue (arg_ty). This is ok because
630 -- we can treat an unlifted value as lifted. But the other way round
631 -- we complain.
632 -- We also want to check if a pointer is cast to a non-ptr etc
633
634 WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
635 return (stg_arg : stg_args, fvs, ticks ++ aticks)
636
637
638 -- ---------------------------------------------------------------------------
639 -- The magic for lets:
640 -- ---------------------------------------------------------------------------
641
642 coreToStgLet
643 :: Bool -- True <=> yes, we are let-no-escaping this let
644 -> CoreBind -- bindings
645 -> CoreExpr -- body
646 -> LneM (StgExpr, -- new let
647 FreeVarsInfo, -- variables free in the whole let
648 EscVarsSet, -- variables that escape from the whole let
649 Bool) -- True <=> none of the binders in the bindings
650 -- is among the escaping vars
651
652 coreToStgLet let_no_escape bind body = do
653 (bind2, bind_fvs, bind_escs,
654 body2, body_fvs, body_escs)
655 <- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do
656
657 ( bind2, bind_fvs, bind_escs, env_ext)
658 <- vars_bind rec_body_fvs bind
659
660 -- Do the body
661 extendVarEnvLne env_ext $ do
662 (body2, body_fvs, body_escs) <- coreToStgExpr body
663
664 return (bind2, bind_fvs, bind_escs,
665 body2, body_fvs, body_escs)
666
667
668 -- Compute the new let-expression
669 let
670 new_let | let_no_escape = StgLetNoEscape bind2 body2
671 | otherwise = StgLet bind2 body2
672
673 free_in_whole_let
674 = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
675
676 real_bind_escs = if let_no_escape then
677 bind_escs
678 else
679 getFVSet bind_fvs
680 -- Everything escapes which is free in the bindings
681
682 let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
683
684 all_escs = bind_escs `unionVarSet` body_escs -- Still includes binders of
685 -- this let(rec)
686
687 no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
688
689 -- Debugging code as requested by Andrew Kennedy
690 checked_no_binder_escapes
691 | debugIsOn && not no_binder_escapes && any is_join_var binders
692 = pprTrace "Interesting! A join var that isn't let-no-escaped" (ppr binders)
693 False
694 | otherwise = no_binder_escapes
695
696 -- Mustn't depend on the passed-in let_no_escape flag, since
697 -- no_binder_escapes is used by the caller to derive the flag!
698 return (
699 new_let,
700 free_in_whole_let,
701 let_escs,
702 checked_no_binder_escapes
703 )
704 where
705 set_of_binders = mkVarSet binders
706 binders = bindersOf bind
707
708 mk_binding binder rhs
709 = (binder, LetBound NestedLet (manifestArity rhs))
710
711 vars_bind :: FreeVarsInfo -- Free var info for body of binding
712 -> CoreBind
713 -> LneM (StgBinding,
714 FreeVarsInfo,
715 EscVarsSet, -- free vars; escapee vars
716 [(Id, HowBound)]) -- extension to environment
717
718
719 vars_bind body_fvs (NonRec binder rhs) = do
720 (rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
721 let
722 env_ext_item = mk_binding binder rhs
723
724 return (StgNonRec binder rhs2,
725 bind_fvs, escs, [env_ext_item])
726
727
728 vars_bind body_fvs (Rec pairs)
729 = mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
730 let
731 rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
732 binders = map fst pairs
733 env_ext = [ mk_binding b rhs
734 | (b,rhs) <- pairs ]
735 in
736 extendVarEnvLne env_ext $ do
737 (rhss2, fvss, escss)
738 <- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs
739 let
740 bind_fvs = unionFVInfos fvss
741 escs = unionVarSets escss
742
743 return (StgRec (binders `zip` rhss2),
744 bind_fvs, escs, env_ext)
745
746
747 is_join_var :: Id -> Bool
748 -- A hack (used only for compiler debuggging) to tell if
749 -- a variable started life as a join point ($j)
750 is_join_var j = occNameString (getOccName j) == "$j"
751
752 coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
753 -> (Id,CoreExpr)
754 -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
755
756 coreToStgRhs scope_fv_info (bndr, rhs) = do
757 (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
758 return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
759 rhs_fvs, rhs_escs)
760 where
761 bndr_info = lookupFVInfo scope_fv_info bndr
762
763 mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
764 mkStgRhs = mkStgRhs' con_updateable
765 where con_updateable _ _ = False
766
767 mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
768 -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
769 mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
770 | StgLam bndrs body <- rhs
771 = StgRhsClosure noCCS binder_info
772 (getFVs rhs_fvs)
773 ReEntrant
774 bndrs body
775 | StgConApp con args <- unticked_rhs
776 , not (con_updateable con args)
777 = StgRhsCon noCCS con args
778 | otherwise
779 = StgRhsClosure noCCS binder_info
780 (getFVs rhs_fvs)
781 upd_flag [] rhs
782 where
783
784 (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
785
786 upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
787 | otherwise = Updatable
788
789 {-
790 SDM: disabled. Eval/Apply can't handle functions with arity zero very
791 well; and making these into simple non-updatable thunks breaks other
792 assumptions (namely that they will be entered only once).
793
794 upd_flag | isPAP env rhs = ReEntrant
795 | otherwise = Updatable
796
797 -- Detect thunks which will reduce immediately to PAPs, and make them
798 -- non-updatable. This has several advantages:
799 --
800 -- - the non-updatable thunk behaves exactly like the PAP,
801 --
802 -- - the thunk is more efficient to enter, because it is
803 -- specialised to the task.
804 --
805 -- - we save one update frame, one stg_update_PAP, one update
806 -- and lots of PAP_enters.
807 --
808 -- - in the case where the thunk is top-level, we save building
809 -- a black hole and futhermore the thunk isn't considered to
810 -- be a CAF any more, so it doesn't appear in any SRTs.
811 --
812 -- We do it here, because the arity information is accurate, and we need
813 -- to do it before the SRT pass to save the SRT entries associated with
814 -- any top-level PAPs.
815
816 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
817 where
818 arity = stgArity f (lookupBinding env f)
819 isPAP env _ = False
820
821 -}
822
823 {- ToDo:
824 upd = if isOnceDem dem
825 then (if isNotTop toplev
826 then SingleEntry -- HA! Paydirt for "dem"
827 else
828 (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
829 Updatable)
830 else Updatable
831 -- For now we forbid SingleEntry CAFs; they tickle the
832 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
833 -- and I don't understand why. There's only one SE_CAF (well,
834 -- only one that tickled a great gaping bug in an earlier attempt
835 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
836 -- specifically Main.lvl6 in spectral/cryptarithm2.
837 -- So no great loss. KSW 2000-07.
838 -}
839
840 -- ---------------------------------------------------------------------------
841 -- A little monad for this let-no-escaping pass
842 -- ---------------------------------------------------------------------------
843
844 -- There's a lot of stuff to pass around, so we use this LneM monad to
845 -- help. All the stuff here is only passed *down*.
846
847 newtype LneM a = LneM
848 { unLneM :: IdEnv HowBound
849 -> a
850 }
851
852 type EscVarsSet = IdSet
853
854 data HowBound
855 = ImportBound -- Used only as a response to lookupBinding; never
856 -- exists in the range of the (IdEnv HowBound)
857
858 | LetBound -- A let(rec) in this module
859 LetInfo -- Whether top level or nested
860 Arity -- Its arity (local Ids don't have arity info at this point)
861
862 | LambdaBound -- Used for both lambda and case
863
864 data LetInfo
865 = TopLet -- top level things
866 | NestedLet
867
868 isLetBound :: HowBound -> Bool
869 isLetBound (LetBound _ _) = True
870 isLetBound _ = False
871
872 topLevelBound :: HowBound -> Bool
873 topLevelBound ImportBound = True
874 topLevelBound (LetBound TopLet _) = True
875 topLevelBound _ = False
876
877 -- For a let(rec)-bound variable, x, we record LiveInfo, the set of
878 -- variables that are live if x is live. This LiveInfo comprises
879 -- (a) dynamic live variables (ones with a non-top-level binding)
880 -- (b) static live variabes (CAFs or things that refer to CAFs)
881 --
882 -- For "normal" variables (a) is just x alone. If x is a let-no-escaped
883 -- variable then x is represented by a code pointer and a stack pointer
884 -- (well, one for each stack). So all of the variables needed in the
885 -- execution of x are live if x is, and are therefore recorded in the
886 -- LetBound constructor; x itself *is* included.
887 --
888 -- The set of dynamic live variables is guaranteed ot have no further
889 -- let-no-escaped variables in it.
890
891 -- The std monad functions:
892
893 initLne :: IdEnv HowBound -> LneM a -> a
894 initLne env m = unLneM m env
895
896
897
898 {-# INLINE thenLne #-}
899 {-# INLINE returnLne #-}
900
901 returnLne :: a -> LneM a
902 returnLne e = LneM $ \_ -> e
903
904 thenLne :: LneM a -> (a -> LneM b) -> LneM b
905 thenLne m k = LneM $ \env
906 -> unLneM (k (unLneM m env)) env
907
908 instance Functor LneM where
909 fmap = liftM
910
911 instance Applicative LneM where
912 pure = returnLne
913 (<*>) = ap
914
915 instance Monad LneM where
916 (>>=) = thenLne
917
918 instance MonadFix LneM where
919 mfix expr = LneM $ \env ->
920 let result = unLneM (expr result) env
921 in result
922
923 -- Functions specific to this monad:
924
925 extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
926 extendVarEnvLne ids_w_howbound expr
927 = LneM $ \env
928 -> unLneM expr (extendVarEnvList env ids_w_howbound)
929
930 lookupVarLne :: Id -> LneM HowBound
931 lookupVarLne v = LneM $ \env -> lookupBinding env v
932
933 lookupBinding :: IdEnv HowBound -> Id -> HowBound
934 lookupBinding env v = case lookupVarEnv env v of
935 Just xx -> xx
936 Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
937
938
939 -- ---------------------------------------------------------------------------
940 -- Free variable information
941 -- ---------------------------------------------------------------------------
942
943 type FreeVarsInfo = VarEnv (Var, HowBound, StgBinderInfo)
944 -- The Var is so we can gather up the free variables
945 -- as a set.
946 --
947 -- The HowBound info just saves repeated lookups;
948 -- we look up just once when we encounter the occurrence.
949 -- INVARIANT: Any ImportBound Ids are HaveCafRef Ids
950 -- Imported Ids without CAF refs are simply
951 -- not put in the FreeVarsInfo for an expression.
952 -- See singletonFVInfo and freeVarsToLiveVars
953 --
954 -- StgBinderInfo records how it occurs; notably, we
955 -- are interested in whether it only occurs in saturated
956 -- applications, because then we don't need to build a
957 -- curried version.
958 -- If f is mapped to noBinderInfo, that means
959 -- that f *is* mentioned (else it wouldn't be in the
960 -- IdEnv at all), but perhaps in an unsaturated applications.
961 --
962 -- All case/lambda-bound things are also mapped to
963 -- noBinderInfo, since we aren't interested in their
964 -- occurrence info.
965 --
966 -- For ILX we track free var info for type variables too;
967 -- hence VarEnv not IdEnv
968
969 emptyFVInfo :: FreeVarsInfo
970 emptyFVInfo = emptyVarEnv
971
972 singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
973 -- Don't record non-CAF imports at all, to keep free-var sets small
974 singletonFVInfo id ImportBound info
975 | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, ImportBound, info)
976 | otherwise = emptyVarEnv
977 singletonFVInfo id how_bound info = unitVarEnv id (id, how_bound, info)
978
979 unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
980 unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
981
982 unionFVInfos :: [FreeVarsInfo] -> FreeVarsInfo
983 unionFVInfos fvs = foldr unionFVInfo emptyFVInfo fvs
984
985 minusFVBinders :: [Id] -> FreeVarsInfo -> FreeVarsInfo
986 minusFVBinders vs fv = foldr minusFVBinder fv vs
987
988 minusFVBinder :: Id -> FreeVarsInfo -> FreeVarsInfo
989 minusFVBinder v fv = fv `delVarEnv` v
990 -- When removing a binder, remember to add its type variables
991 -- c.f. CoreFVs.delBinderFV
992
993 elementOfFVInfo :: Id -> FreeVarsInfo -> Bool
994 elementOfFVInfo id fvs = isJust (lookupVarEnv fvs id)
995
996 lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo
997 -- Find how the given Id is used.
998 -- Externally visible things may be used any old how
999 lookupFVInfo fvs id
1000 | isExternalName (idName id) = noBinderInfo
1001 | otherwise = case lookupVarEnv fvs id of
1002 Nothing -> noBinderInfo
1003 Just (_,_,info) -> info
1004
1005 -- Non-top-level things only, both type variables and ids
1006 getFVs :: FreeVarsInfo -> [Var]
1007 getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
1008 not (topLevelBound how_bound) ]
1009
1010 getFVSet :: FreeVarsInfo -> VarSet
1011 getFVSet fvs = mkVarSet (getFVs fvs)
1012
1013 plusFVInfo :: (Var, HowBound, StgBinderInfo)
1014 -> (Var, HowBound, StgBinderInfo)
1015 -> (Var, HowBound, StgBinderInfo)
1016 plusFVInfo (id1,hb1,info1) (id2,hb2,info2)
1017 = ASSERT(id1 == id2 && hb1 `check_eq_how_bound` hb2)
1018 (id1, hb1, combineStgBinderInfo info1 info2)
1019
1020 -- The HowBound info for a variable in the FVInfo should be consistent
1021 check_eq_how_bound :: HowBound -> HowBound -> Bool
1022 check_eq_how_bound ImportBound ImportBound = True
1023 check_eq_how_bound LambdaBound LambdaBound = True
1024 check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_eq_li li1 li2
1025 check_eq_how_bound _ _ = False
1026
1027 check_eq_li :: LetInfo -> LetInfo -> Bool
1028 check_eq_li NestedLet NestedLet = True
1029 check_eq_li TopLet TopLet = True
1030 check_eq_li _ _ = False
1031
1032 -- Misc.
1033
1034 filterStgBinders :: [Var] -> [Var]
1035 filterStgBinders bndrs = filter isId bndrs
1036
1037 myCollectBinders :: Expr Var -> ([Var], Expr Var)
1038 myCollectBinders expr
1039 = go [] expr
1040 where
1041 go bs (Lam b e) = go (b:bs) e
1042 go bs (Cast e _) = go bs e
1043 go bs e = (reverse bs, e)
1044
1045 myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
1046 -- We assume that we only have variables
1047 -- in the function position by now
1048 myCollectArgs expr
1049 = go expr [] []
1050 where
1051 go (Var v) as ts = (v, as, ts)
1052 go (App f a) as ts = go f (a:as) ts
1053 go (Tick t e) as ts = ASSERT( all isTypeArg as )
1054 go e as (t:ts) -- ticks can appear in type apps
1055 go (Cast e _) as ts = go e as ts
1056 go (Lam b e) as ts
1057 | isTyVar b = go e as ts -- Note [Collect args]
1058 go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
1059
1060 -- Note [Collect args]
1061 -- ~~~~~~~~~~~~~~~~~~~
1062 --
1063 -- This big-lambda case occurred following a rather obscure eta expansion.
1064 -- It all seems a bit yukky to me.
1065
1066 stgArity :: Id -> HowBound -> Arity
1067 stgArity _ (LetBound _ arity) = arity
1068 stgArity f ImportBound = idArity f
1069 stgArity _ LambdaBound = 0