never executed always true always false
1
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 --
6 -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
7 --
8
9 --------------------------------------------------------------
10 -- Converting Core to STG Syntax
11 --------------------------------------------------------------
12
13 -- And, as we have the info in hand, we may convert some lets to
14 -- let-no-escapes.
15
16 module GHC.CoreToStg ( coreToStg ) where
17
18 import GHC.Prelude
19
20 import GHC.Driver.Session
21
22 import GHC.Core
23 import GHC.Core.Utils ( exprType, findDefault, isJoinBind
24 , exprIsTickedString_maybe )
25 import GHC.Core.Opt.Arity ( manifestArity )
26 import GHC.Core.Type
27 import GHC.Core.TyCon
28 import GHC.Core.DataCon
29
30 import GHC.Stg.Syntax
31 import GHC.Stg.Debug
32
33 import GHC.Types.RepType
34 import GHC.Types.Id.Make ( coercionTokenId )
35 import GHC.Types.Id
36 import GHC.Types.Id.Info
37 import GHC.Types.CostCentre
38 import GHC.Types.Tickish
39 import GHC.Types.Var.Env
40 import GHC.Types.Name ( isExternalName, nameModule_maybe )
41 import GHC.Types.Basic ( Arity )
42 import GHC.Types.Literal
43 import GHC.Types.ForeignCall
44 import GHC.Types.IPE
45 import GHC.Types.Demand ( isUsedOnceDmd )
46 import GHC.Types.SrcLoc ( mkGeneralSrcSpan )
47
48 import GHC.Unit.Module
49 import GHC.Builtin.Types ( unboxedUnitDataCon )
50 import GHC.Data.FastString
51 import GHC.Platform.Ways
52 import GHC.Builtin.PrimOps ( PrimCall(..) )
53
54 import GHC.Utils.Outputable
55 import GHC.Utils.Monad
56 import GHC.Utils.Misc (HasDebugCallStack)
57 import GHC.Utils.Panic
58 import GHC.Utils.Panic.Plain
59 import GHC.Utils.Trace
60
61 import Control.Monad (ap)
62 import Data.Maybe (fromMaybe)
63 import Data.Tuple (swap)
64
65 -- Note [Live vs free]
66 -- ~~~~~~~~~~~~~~~~~~~
67 --
68 -- The two are not the same. Liveness is an operational property rather
69 -- than a semantic one. A variable is live at a particular execution
70 -- point if it can be referred to directly again. In particular, a dead
71 -- variable's stack slot (if it has one):
72 --
73 -- - should be stubbed to avoid space leaks, and
74 -- - may be reused for something else.
75 --
76 -- There ought to be a better way to say this. Here are some examples:
77 --
78 -- let v = [q] \[x] -> e
79 -- in
80 -- ...v... (but no q's)
81 --
82 -- Just after the `in', v is live, but q is dead. If the whole of that
83 -- let expression was enclosed in a case expression, thus:
84 --
85 -- case (let v = [q] \[x] -> e in ...v...) of
86 -- alts[...q...]
87 --
88 -- (ie `alts' mention `q'), then `q' is live even after the `in'; because
89 -- we'll return later to the `alts' and need it.
90 --
91 -- Let-no-escapes make this a bit more interesting:
92 --
93 -- let-no-escape v = [q] \ [x] -> e
94 -- in
95 -- ...v...
96 --
97 -- Here, `q' is still live at the `in', because `v' is represented not by
98 -- a closure but by the current stack state. In other words, if `v' is
99 -- live then so is `q'. Furthermore, if `e' mentions an enclosing
100 -- let-no-escaped variable, then its free variables are also live if `v' is.
101
102 -- Note [What are these SRTs all about?]
103 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 --
105 -- Consider the Core program,
106 --
107 -- fibs = go 1 1
108 -- where go a b = let c = a + c
109 -- in c : go b c
110 -- add x = map (\y -> x*y) fibs
111 --
112 -- In this case we have a CAF, 'fibs', which is quite large after evaluation and
113 -- has only one possible user, 'add'. Consequently, we want to ensure that when
114 -- all references to 'add' die we can garbage collect any bit of 'fibs' that we
115 -- have evaluated.
116 --
117 -- However, how do we know whether there are any references to 'fibs' still
118 -- around? Afterall, the only reference to it is buried in the code generated
119 -- for 'add'. The answer is that we record the CAFs referred to by a definition
120 -- in its info table, namely a part of it known as the Static Reference Table
121 -- (SRT).
122 --
123 -- Since SRTs are so common, we use a special compact encoding for them in: we
124 -- produce one table containing a list of CAFs in a module and then include a
125 -- bitmap in each info table describing which entries of this table the closure
126 -- references.
127 --
128 -- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.
129
130 -- Note [What is a non-escaping let]
131 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
132 --
133 -- NB: Nowadays this is recognized by the occurrence analyser by turning a
134 -- "non-escaping let" into a join point. The following is then an operational
135 -- account of join points.
136 --
137 -- Consider:
138 --
139 -- let x = fvs \ args -> e
140 -- in
141 -- if ... then x else
142 -- if ... then x else ...
143 --
144 -- `x' is used twice (so we probably can't unfold it), but when it is
145 -- entered, the stack is deeper than it was when the definition of `x'
146 -- happened. Specifically, if instead of allocating a closure for `x',
147 -- we saved all `x's fvs on the stack, and remembered the stack depth at
148 -- that moment, then whenever we enter `x' we can simply set the stack
149 -- pointer(s) to these remembered (compile-time-fixed) values, and jump
150 -- to the code for `x'.
151 --
152 -- All of this is provided x is:
153 -- 1. non-updatable;
154 -- 2. guaranteed to be entered before the stack retreats -- ie x is not
155 -- buried in a heap-allocated closure, or passed as an argument to
156 -- something;
157 -- 3. all the enters have exactly the right number of arguments,
158 -- no more no less;
159 -- 4. all the enters are tail calls; that is, they return to the
160 -- caller enclosing the definition of `x'.
161 --
162 -- Under these circumstances we say that `x' is non-escaping.
163 --
164 -- An example of when (4) does not hold:
165 --
166 -- let x = ...
167 -- in case x of ...alts...
168 --
169 -- Here, `x' is certainly entered only when the stack is deeper than when
170 -- `x' is defined, but here it must return to ...alts... So we can't just
171 -- adjust the stack down to `x''s recalled points, because that would lost
172 -- alts' context.
173 --
174 -- Things can get a little more complicated. Consider:
175 --
176 -- let y = ...
177 -- in let x = fvs \ args -> ...y...
178 -- in ...x...
179 --
180 -- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
181 -- non-escaping way in ...y..., then `y' is non-escaping.
182 --
183 -- `x' can even be recursive! Eg:
184 --
185 -- letrec x = [y] \ [v] -> if v then x True else ...
186 -- in
187 -- ...(x b)...
188
189 -- Note [Cost-centre initialization plan]
190 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
191 --
192 -- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
193 -- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
194 -- We now initialize these correctly. The initialization works like this:
195 --
196 -- - For non-top level bindings always use `currentCCS`.
197 --
198 -- - For top-level bindings, check if the binding is a CAF
199 --
200 -- - CAF: If -fcaf-all is enabled, create a new CAF just for this CAF
201 -- and use it. Note that these new cost centres need to be
202 -- collected to be able to generate cost centre initialization
203 -- code, so `coreToTopStgRhs` now returns `CollectedCCs`.
204 --
205 -- If -fcaf-all is not enabled, use "all CAFs" cost centre.
206 --
207 -- - Non-CAF: Top-level (static) data is not counted in heap profiles; nor
208 -- do we set CCCS from it; so we just slam in
209 -- dontCareCostCentre.
210
211 -- Note [Coercion tokens]
212 -- ~~~~~~~~~~~~~~~~~~~~~~
213 -- In coreToStgArgs, we drop type arguments completely, but we replace
214 -- coercions with a special coercionToken# placeholder. Why? Consider:
215 --
216 -- f :: forall a. Int ~# Bool -> a
217 -- f = /\a. \(co :: Int ~# Bool) -> error "impossible"
218 --
219 -- If we erased the coercion argument completely, we’d end up with just
220 -- f = error "impossible", but then f `seq` () would be ⊥!
221 --
222 -- This is an artificial example, but back in the day we *did* treat
223 -- coercion lambdas like type lambdas, and we had bug reports as a
224 -- result. So now we treat coercion lambdas like value lambdas, but we
225 -- treat coercions themselves as zero-width arguments — coercionToken#
226 -- has representation VoidRep — which gets the best of both worlds.
227 --
228 -- (For the gory details, see also the (unpublished) paper, “Practical
229 -- aspects of evidence-based compilation in System FC.”)
230
231 -- --------------------------------------------------------------
232 -- Setting variable info: top-level, binds, RHSs
233 -- --------------------------------------------------------------
234
235
236 coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram
237 -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
238 coreToStg dflags this_mod ml pgm
239 = (pgm'', denv, final_ccs)
240 where
241 (_, (local_ccs, local_cc_stacks), pgm')
242 = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
243
244 -- See Note [Mapping Info Tables to Source Positions]
245 (!pgm'', !denv) =
246 if gopt Opt_InfoTableMap dflags
247 then collectDebugInformation dflags ml pgm'
248 else (pgm', emptyInfoTableProvMap)
249
250 prof = ways dflags `hasWay` WayProf
251
252 final_ccs
253 | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
254 = (local_ccs,local_cc_stacks) -- don't need "all CAFs" CC
255 | prof
256 = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
257 | otherwise
258 = emptyCollectedCCs
259
260 (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
261
262 coreTopBindsToStg
263 :: DynFlags
264 -> Module
265 -> IdEnv HowBound -- environment for the bindings
266 -> CollectedCCs
267 -> CoreProgram
268 -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
269
270 coreTopBindsToStg _ _ env ccs []
271 = (env, ccs, [])
272 coreTopBindsToStg dflags this_mod env ccs (b:bs)
273 | NonRec _ rhs <- b, isTyCoArg rhs
274 = coreTopBindsToStg dflags this_mod env1 ccs1 bs
275 | otherwise
276 = (env2, ccs2, b':bs')
277 where
278 (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b
279 (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs
280
281 coreTopBindToStg
282 :: DynFlags
283 -> Module
284 -> IdEnv HowBound
285 -> CollectedCCs
286 -> CoreBind
287 -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
288
289 coreTopBindToStg _ _ env ccs (NonRec id e)
290 | Just str <- exprIsTickedString_maybe e
291 -- top-level string literal
292 -- See Note [Core top-level string literals] in GHC.Core
293 = let
294 env' = extendVarEnv env id how_bound
295 how_bound = LetBound TopLet 0
296 in (env', ccs, StgTopStringLit id str)
297
298 coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
299 = let
300 env' = extendVarEnv env id how_bound
301 how_bound = LetBound TopLet $! manifestArity rhs
302
303 (stg_rhs, ccs') =
304 initCts dflags env $
305 coreToTopStgRhs dflags ccs this_mod (id,rhs)
306
307 bind = StgTopLifted $ StgNonRec id stg_rhs
308 in
309 -- NB: previously the assertion printed 'rhs' and 'bind'
310 -- as well as 'id', but that led to a black hole
311 -- where printing the assertion error tripped the
312 -- assertion again!
313 (env', ccs', bind)
314
315 coreTopBindToStg dflags this_mod env ccs (Rec pairs)
316 = assert (not (null pairs)) $
317 let
318 binders = map fst pairs
319
320 extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
321 | (b, rhs) <- pairs ]
322 env' = extendVarEnvList env extra_env'
323
324 -- generate StgTopBindings and CAF cost centres created for CAFs
325 (ccs', stg_rhss)
326 = initCts dflags env' $
327 mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)
328 ccs
329 pairs
330 bind = StgTopLifted $ StgRec (zip binders stg_rhss)
331 in
332 (env', ccs', bind)
333
334 coreToTopStgRhs
335 :: DynFlags
336 -> CollectedCCs
337 -> Module
338 -> (Id,CoreExpr)
339 -> CtsM (StgRhs, CollectedCCs)
340
341 coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
342 = do { new_rhs <- coreToPreStgRhs rhs
343
344 ; let (stg_rhs, ccs') =
345 mkTopStgRhs dflags this_mod ccs bndr new_rhs
346 stg_arity =
347 stgRhsArity stg_rhs
348
349 ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,
350 ccs') }
351 where
352 -- It's vital that the arity on a top-level Id matches
353 -- the arity of the generated STG binding, else an importing
354 -- module will use the wrong calling convention
355 -- (#2844 was an example where this happened)
356 -- NB1: we can't move the assertion further out without
357 -- blocking the "knot" tied in coreTopBindsToStg
358 -- NB2: the arity check is only needed for Ids with External
359 -- Names, because they are externally visible. The CorePrep
360 -- pass introduces "sat" things with Local Names and does
361 -- not bother to set their Arity info, so don't fail for those
362 arity_ok stg_arity
363 | isExternalName (idName bndr) = id_arity == stg_arity
364 | otherwise = True
365 id_arity = idArity bndr
366 mk_arity_msg stg_arity
367 = vcat [ppr bndr,
368 text "Id arity:" <+> ppr id_arity,
369 text "STG arity:" <+> ppr stg_arity]
370
371 -- ---------------------------------------------------------------------------
372 -- Expressions
373 -- ---------------------------------------------------------------------------
374
375 -- coreToStgExpr panics if the input expression is a value lambda. CorePrep
376 -- ensures that value lambdas only exist as the RHS of bindings, which we
377 -- handle with the function coreToPreStgRhs.
378
379 coreToStgExpr
380 :: HasDebugCallStack => CoreExpr
381 -> CtsM StgExpr
382
383 -- The second and third components can be derived in a simple bottom up pass, not
384 -- dependent on any decisions about which variables will be let-no-escaped or
385 -- not. The first component, that is, the decorated expression, may then depend
386 -- on these components, but it in turn is not scrutinised as the basis for any
387 -- decisions. Hence no black holes.
388
389 -- No bignum literal should be left by the time this is called.
390 -- CorePrep should have converted them all to a real core representation.
391 coreToStgExpr (Lit (LitNumber LitNumBigNat _)) = panic "coreToStgExpr: LitNumBigNat"
392 coreToStgExpr (Lit l) = return (StgLit l)
393 coreToStgExpr (Var v) = coreToStgApp v [] []
394 coreToStgExpr (Coercion _)
395 -- See Note [Coercion tokens]
396 = coreToStgApp coercionTokenId [] []
397
398 coreToStgExpr expr@(App _ _)
399 = case app_head of
400 Var f -> coreToStgApp f args ticks -- Regular application
401 Lit l | isLitRubbish l -- If there is LitRubbish at the head,
402 -> return (StgLit l) -- discard the arguments
403
404 _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)
405 where
406 (app_head, args, ticks) = myCollectArgs expr
407 coreToStgExpr expr@(Lam _ _)
408 = let
409 (args, body) = myCollectBinders expr
410 in
411 case filterStgBinders args of
412
413 [] -> coreToStgExpr body
414
415 _ -> pprPanic "coretoStgExpr" $
416 text "Unexpected value lambda:" $$ ppr expr
417
418 coreToStgExpr (Tick tick expr)
419 = do
420 let !stg_tick = coreToStgTick (exprType expr) tick
421 !expr2 <- coreToStgExpr expr
422 return (StgTick stg_tick expr2)
423
424 coreToStgExpr (Cast expr _)
425 = coreToStgExpr expr
426
427 -- Cases require a little more real work.
428
429 {-
430 coreToStgExpr (Case scrut _ _ [])
431 = coreToStgExpr scrut
432 -- See Note [Empty case alternatives] in GHC.Core If the case
433 -- alternatives are empty, the scrutinee must diverge or raise an
434 -- exception, so we can just dive into it.
435 --
436 -- Of course this may seg-fault if the scrutinee *does* return. A
437 -- belt-and-braces approach would be to move this case into the
438 -- code generator, and put a return point anyway that calls a
439 -- runtime system error function.
440
441 coreToStgExpr e0@(Case scrut bndr _ [alt]) = do
442 | isUnsafeEqualityProof scrut
443 , isDeadBinder bndr -- We can only discard the case if the case-binder is dead
444 -- It usually is, but see #18227
445 , (_,_,rhs) <- alt
446 = coreToStgExpr rhs
447 -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
448 -}
449
450 -- The normal case for case-expressions
451 coreToStgExpr (Case scrut bndr _ alts)
452 = do { scrut2 <- coreToStgExpr scrut
453 ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
454 ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
455 where
456 vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)
457 vars_alt (Alt con binders rhs)
458 | DataAlt c <- con, c == unboxedUnitDataCon
459 = -- This case is a bit smelly.
460 -- See Note [Nullary unboxed tuple] in GHC.Core.Type
461 -- where a nullary tuple is mapped to (State# World#)
462 assert (null binders) $
463 do { rhs2 <- coreToStgExpr rhs
464 ; return (DEFAULT, [], rhs2) }
465 | otherwise
466 = let -- Remove type variables
467 binders' = filterStgBinders binders
468 in
469 extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
470 rhs2 <- coreToStgExpr rhs
471 return (con, binders', rhs2)
472
473 coreToStgExpr (Let bind body) = coreToStgLet bind body
474 coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
475
476 mkStgAltType :: Id -> [CoreAlt] -> AltType
477 mkStgAltType bndr alts
478 | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
479 = MultiValAlt (length prim_reps) -- always use MultiValAlt for unboxed tuples
480
481 | otherwise
482 = case prim_reps of
483 [rep] | isGcPtrRep rep ->
484 case tyConAppTyCon_maybe (unwrapType bndr_ty) of
485 Just tc
486 | isAbstractTyCon tc -> look_for_better_tycon
487 | isAlgTyCon tc -> AlgAlt tc
488 | otherwise -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt
489 Nothing -> PolyAlt
490 [non_gcd] -> PrimAlt non_gcd
491 not_unary -> MultiValAlt (length not_unary)
492 where
493 bndr_ty = idType bndr
494 prim_reps = typePrimRep bndr_ty
495
496 _is_poly_alt_tycon tc
497 = isFunTyCon tc
498 || isPrimTyCon tc -- "Any" is lifted but primitive
499 || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
500 -- function application where argument has a
501 -- type-family type
502
503 -- Sometimes, the TyCon is a AbstractTyCon which may not have any
504 -- constructors inside it. Then we may get a better TyCon by
505 -- grabbing the one from a constructor alternative
506 -- if one exists.
507 look_for_better_tycon
508 | ((Alt (DataAlt con) _ _) : _) <- data_alts =
509 AlgAlt (dataConTyCon con)
510 | otherwise =
511 assert (null data_alts)
512 PolyAlt
513 where
514 (data_alts, _deflt) = findDefault alts
515
516 -- ---------------------------------------------------------------------------
517 -- Applications
518 -- ---------------------------------------------------------------------------
519
520 coreToStgApp :: Id -- Function
521 -> [CoreArg] -- Arguments
522 -> [CoreTickish] -- Debug ticks
523 -> CtsM StgExpr
524 coreToStgApp f args ticks = do
525 (args', ticks') <- coreToStgArgs args
526 how_bound <- lookupVarCts f
527
528 let
529 n_val_args = valArgCount args
530
531 -- Mostly, the arity info of a function is in the fn's IdInfo
532 -- But new bindings introduced by CoreSat may not have no
533 -- arity info; it would do us no good anyway. For example:
534 -- let f = \ab -> e in f
535 -- No point in having correct arity info for f!
536 -- Hence the hasArity stuff below.
537 -- NB: f_arity is only consulted for LetBound things
538 f_arity = stgArity f how_bound
539 saturated = f_arity <= n_val_args
540
541 res_ty = exprType (mkApps (Var f) args)
542 app = case idDetails f of
543 DataConWorkId dc
544 | saturated -> StgConApp dc NoNumber args'
545 (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
546
547 -- Some primitive operator that might be implemented as a library call.
548 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
549 -- we require that primop applications be saturated.
550 PrimOpId op -> assert saturated $
551 StgOpApp (StgPrimOp op) args' res_ty
552
553 -- A call to some primitive Cmm function.
554 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
555 PrimCallConv _))
556 -> assert saturated $
557 StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
558
559 -- A regular foreign call.
560 FCallId call -> assert saturated $
561 StgOpApp (StgFCallOp call (idType f)) args' res_ty
562
563 TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
564 _other -> StgApp f args'
565
566 add_tick !t !e = StgTick t e
567 tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')
568
569 -- Forcing these fixes a leak in the code generator, noticed while
570 -- profiling for trac #4367
571 app `seq` return tapp
572
573 -- ---------------------------------------------------------------------------
574 -- Argument lists
575 -- This is the guy that turns applications into A-normal form
576 -- ---------------------------------------------------------------------------
577
578 coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
579 coreToStgArgs []
580 = return ([], [])
581
582 coreToStgArgs (Type _ : args) = do -- Type argument
583 (args', ts) <- coreToStgArgs args
584 return (args', ts)
585
586 coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens]
587 = do { (args', ts) <- coreToStgArgs args
588 ; return (StgVarArg coercionTokenId : args', ts) }
589
590 coreToStgArgs (Tick t e : args)
591 = assert (not (tickishIsCode t)) $
592 do { (args', ts) <- coreToStgArgs (e : args)
593 ; let !t' = coreToStgTick (exprType e) t
594 ; return (args', t':ts) }
595
596 coreToStgArgs (arg : args) = do -- Non-type argument
597 (stg_args, ticks) <- coreToStgArgs args
598 arg' <- coreToStgExpr arg
599 let
600 (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
601 stg_arg = case arg'' of
602 StgApp v [] -> StgVarArg v
603 StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)
604 StgLit lit -> StgLitArg lit
605 _ -> pprPanic "coreToStgArgs" (ppr arg)
606
607 -- WARNING: what if we have an argument like (v `cast` co)
608 -- where 'co' changes the representation type?
609 -- (This really only happens if co is unsafe.)
610 -- Then all the getArgAmode stuff in CgBindery will set the
611 -- cg_rep of the CgIdInfo based on the type of v, rather
612 -- than the type of 'co'.
613 -- This matters particularly when the function is a primop
614 -- or foreign call.
615 -- Wanted: a better solution than this hacky warning
616
617 platform <- targetPlatform <$> getDynFlags
618 let
619 arg_rep = typePrimRep (exprType arg)
620 stg_arg_rep = typePrimRep (stgArgType stg_arg)
621 bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
622
623 warnPprTrace bad_args (text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg) $
624 return (stg_arg : stg_args, ticks ++ aticks)
625
626 coreToStgTick :: Type -- type of the ticked expression
627 -> CoreTickish
628 -> StgTickish
629 coreToStgTick _ty (HpcTick m i) = HpcTick m i
630 coreToStgTick _ty (SourceNote span nm) = SourceNote span nm
631 coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
632 coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs
633
634 -- ---------------------------------------------------------------------------
635 -- The magic for lets:
636 -- ---------------------------------------------------------------------------
637
638 coreToStgLet
639 :: CoreBind -- bindings
640 -> CoreExpr -- body
641 -> CtsM StgExpr -- new let
642
643 coreToStgLet bind body
644 | NonRec _ rhs <- bind, isTyCoArg rhs
645 = coreToStgExpr body
646
647 | otherwise
648 = do { (bind2, env_ext) <- vars_bind bind
649
650 -- Do the body
651 ; body2 <- extendVarEnvCts env_ext $
652 coreToStgExpr body
653
654 -- Compute the new let-expression
655 ; let new_let | isJoinBind bind
656 = StgLetNoEscape noExtFieldSilent bind2 body2
657 | otherwise
658 = StgLet noExtFieldSilent bind2 body2
659
660 ; return new_let }
661 where
662 mk_binding binder rhs
663 = (binder, LetBound NestedLet (manifestArity rhs))
664
665 vars_bind :: CoreBind
666 -> CtsM (StgBinding,
667 [(Id, HowBound)]) -- extension to environment
668
669 vars_bind (NonRec binder rhs) = do
670 rhs2 <- coreToStgRhs (binder,rhs)
671 let
672 env_ext_item = mk_binding binder rhs
673
674 return (StgNonRec binder rhs2, [env_ext_item])
675
676 vars_bind (Rec pairs)
677 = let
678 binders = map fst pairs
679 env_ext = [ mk_binding b rhs
680 | (b,rhs) <- pairs ]
681 in
682 extendVarEnvCts env_ext $ do
683 rhss2 <- mapM coreToStgRhs pairs
684 return (StgRec (binders `zip` rhss2), env_ext)
685
686 coreToStgRhs :: (Id,CoreExpr)
687 -> CtsM StgRhs
688
689 coreToStgRhs (bndr, rhs) = do
690 new_rhs <- coreToPreStgRhs rhs
691 return (mkStgRhs bndr new_rhs)
692
693 -- Represents the RHS of a binding for use with mk(Top)StgRhs.
694 data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks
695
696 -- Convert the RHS of a binding from Core to STG. This is a wrapper around
697 -- coreToStgExpr that can handle value lambdas.
698 coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
699 coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr
700 coreToPreStgRhs expr@(Lam _ _) =
701 let
702 (args, body) = myCollectBinders expr
703 args' = filterStgBinders args
704 in
705 extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
706 body' <- coreToStgExpr body
707 return (PreStgRhs args' body')
708 coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr
709
710 -- Generate a top-level RHS. Any new cost centres generated for CAFs will be
711 -- appended to `CollectedCCs` argument.
712 mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
713 -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
714
715 mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)
716 | not (null bndrs)
717 = -- The list of arguments is non-empty, so not CAF
718 ( StgRhsClosure noExtFieldSilent
719 dontCareCCS
720 ReEntrant
721 bndrs rhs
722 , ccs )
723
724 -- After this point we know that `bndrs` is empty,
725 -- so this is not a function binding
726 | StgConApp con mn args _ <- unticked_rhs
727 , -- Dynamic StgConApps are updatable
728 not (isDllConApp dflags this_mod con args)
729 = -- CorePrep does this right, but just to make sure
730 assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
731 (ppr bndr $$ ppr con $$ ppr args)
732 ( StgRhsCon dontCareCCS con mn ticks args, ccs )
733
734 -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
735 | gopt Opt_AutoSccsOnIndividualCafs dflags
736 = ( StgRhsClosure noExtFieldSilent
737 caf_ccs
738 upd_flag [] rhs
739 , collectCC caf_cc caf_ccs ccs )
740
741 | otherwise
742 = ( StgRhsClosure noExtFieldSilent
743 all_cafs_ccs
744 upd_flag [] rhs
745 , ccs )
746
747 where
748 (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
749
750 upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
751 | otherwise = Updatable
752
753 -- CAF cost centres generated for -fcaf-all
754 caf_cc = mkAutoCC bndr modl
755 caf_ccs = mkSingletonCCS caf_cc
756 -- careful: the binder might be :Main.main,
757 -- which doesn't belong to module mod_name.
758 -- bug #249, tests prof001, prof002
759 modl | Just m <- nameModule_maybe (idName bndr) = m
760 | otherwise = this_mod
761
762 -- default CAF cost centre
763 (_, all_cafs_ccs) = getAllCAFsCC this_mod
764
765 -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
766 -- see Note [Cost-centre initialization plan].
767 mkStgRhs :: Id -> PreStgRhs -> StgRhs
768 mkStgRhs bndr (PreStgRhs bndrs rhs)
769 | not (null bndrs)
770 = StgRhsClosure noExtFieldSilent
771 currentCCS
772 ReEntrant
773 bndrs rhs
774
775 -- After this point we know that `bndrs` is empty,
776 -- so this is not a function binding
777
778 | isJoinId bndr -- Must be a nullary join point
779 = -- It might have /type/ arguments (T18328),
780 -- so its JoinArity might be >0
781 StgRhsClosure noExtFieldSilent
782 currentCCS
783 ReEntrant -- ignored for LNE
784 [] rhs
785
786 | StgConApp con mn args _ <- unticked_rhs
787 = StgRhsCon currentCCS con mn ticks args
788
789 | otherwise
790 = StgRhsClosure noExtFieldSilent
791 currentCCS
792 upd_flag [] rhs
793 where
794 (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
795
796 upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
797 | otherwise = Updatable
798
799 {-
800 SDM: disabled. Eval/Apply can't handle functions with arity zero very
801 well; and making these into simple non-updatable thunks breaks other
802 assumptions (namely that they will be entered only once).
803
804 upd_flag | isPAP env rhs = ReEntrant
805 | otherwise = Updatable
806
807 -- Detect thunks which will reduce immediately to PAPs, and make them
808 -- non-updatable. This has several advantages:
809 --
810 -- - the non-updatable thunk behaves exactly like the PAP,
811 --
812 -- - the thunk is more efficient to enter, because it is
813 -- specialised to the task.
814 --
815 -- - we save one update frame, one stg_update_PAP, one update
816 -- and lots of PAP_enters.
817 --
818 -- - in the case where the thunk is top-level, we save building
819 -- a black hole and furthermore the thunk isn't considered to
820 -- be a CAF any more, so it doesn't appear in any SRTs.
821 --
822 -- We do it here, because the arity information is accurate, and we need
823 -- to do it before the SRT pass to save the SRT entries associated with
824 -- any top-level PAPs.
825
826 isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
827 where
828 arity = stgArity f (lookupBinding env f)
829 isPAP env _ = False
830
831 -}
832
833 {- ToDo:
834 upd = if isOnceDem dem
835 then (if isNotTop toplev
836 then SingleEntry -- HA! Paydirt for "dem"
837 else
838 (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
839 Updatable)
840 else Updatable
841 -- For now we forbid SingleEntry CAFs; they tickle the
842 -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
843 -- and I don't understand why. There's only one SE_CAF (well,
844 -- only one that tickled a great gaping bug in an earlier attempt
845 -- at ClosureInfo.getEntryConvention) in the whole of nofib,
846 -- specifically Main.lvl6 in spectral/cryptarithm2.
847 -- So no great loss. KSW 2000-07.
848 -}
849
850 -- ---------------------------------------------------------------------------
851 -- A monad for the core-to-STG pass
852 -- ---------------------------------------------------------------------------
853
854 -- There's a lot of stuff to pass around, so we use this CtsM
855 -- ("core-to-STG monad") monad to help. All the stuff here is only passed
856 -- *down*.
857
858 newtype CtsM a = CtsM
859 { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
860 -> IdEnv HowBound
861 -> a
862 }
863 deriving (Functor)
864
865 data HowBound
866 = ImportBound -- Used only as a response to lookupBinding; never
867 -- exists in the range of the (IdEnv HowBound)
868
869 | LetBound -- A let(rec) in this module
870 LetInfo -- Whether top level or nested
871 Arity -- Its arity (local Ids don't have arity info at this point)
872
873 | LambdaBound -- Used for both lambda and case
874 deriving (Eq)
875
876 data LetInfo
877 = TopLet -- top level things
878 | NestedLet
879 deriving (Eq)
880
881 -- For a let(rec)-bound variable, x, we record LiveInfo, the set of
882 -- variables that are live if x is live. This LiveInfo comprises
883 -- (a) dynamic live variables (ones with a non-top-level binding)
884 -- (b) static live variables (CAFs or things that refer to CAFs)
885 --
886 -- For "normal" variables (a) is just x alone. If x is a let-no-escaped
887 -- variable then x is represented by a code pointer and a stack pointer
888 -- (well, one for each stack). So all of the variables needed in the
889 -- execution of x are live if x is, and are therefore recorded in the
890 -- LetBound constructor; x itself *is* included.
891 --
892 -- The set of dynamic live variables is guaranteed ot have no further
893 -- let-no-escaped variables in it.
894
895 -- The std monad functions:
896
897 initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
898 initCts dflags env m = unCtsM m dflags env
899
900
901
902 {-# INLINE thenCts #-}
903 {-# INLINE returnCts #-}
904
905 returnCts :: a -> CtsM a
906 returnCts e = CtsM $ \_ _ -> e
907
908 thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
909 thenCts m k = CtsM $ \dflags env
910 -> unCtsM (k (unCtsM m dflags env)) dflags env
911
912 instance Applicative CtsM where
913 pure = returnCts
914 (<*>) = ap
915
916 instance Monad CtsM where
917 (>>=) = thenCts
918
919 instance HasDynFlags CtsM where
920 getDynFlags = CtsM $ \dflags _ -> dflags
921
922 -- Functions specific to this monad:
923
924 extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
925 extendVarEnvCts ids_w_howbound expr
926 = CtsM $ \dflags env
927 -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
928
929 lookupVarCts :: Id -> CtsM HowBound
930 lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
931
932 lookupBinding :: IdEnv HowBound -> Id -> HowBound
933 lookupBinding env v = case lookupVarEnv env v of
934 Just xx -> xx
935 Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
936
937 getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
938 getAllCAFsCC this_mod =
939 let
940 span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
941 all_cafs_cc = mkAllCafsCC this_mod span
942 all_cafs_ccs = mkSingletonCCS all_cafs_cc
943 in
944 (all_cafs_cc, all_cafs_ccs)
945
946 -- Misc.
947
948 filterStgBinders :: [Var] -> [Var]
949 filterStgBinders bndrs = filter isId bndrs
950
951 myCollectBinders :: Expr Var -> ([Var], Expr Var)
952 myCollectBinders expr
953 = go [] expr
954 where
955 go bs (Lam b e) = go (b:bs) e
956 go bs (Cast e _) = go bs e
957 go bs e = (reverse bs, e)
958
959 -- | If the argument expression is (potential chain of) 'App', return the head
960 -- of the app chain, and collect ticks/args along the chain.
961 myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
962 myCollectArgs expr
963 = go expr [] []
964 where
965 go h@(Var _v) as ts = (h, as, ts)
966 go (App f a) as ts = go f (a:as) ts
967 go (Tick t e) as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)
968 (ppr e $$ ppr as $$ ppr ts) $
969 -- See Note [Ticks in applications]
970 go e as (t:ts) -- ticks can appear in type apps
971 go (Cast e _) as ts = go e as ts
972 go (Lam b e) as ts
973 | isTyVar b = go e as ts -- Note [Collect args]
974 go e as ts = (e, as, ts)
975
976 {- Note [Collect args]
977 ~~~~~~~~~~~~~~~~~~~~~~
978 This big-lambda case occurred following a rather obscure eta expansion.
979 It all seems a bit yukky to me.
980
981 Note [Ticks in applications]
982 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
983 We can get an application like
984 (tick t f) True False
985 via inlining in the CorePrep pass; see Note [Inlining in CorePrep]
986 in GHC.CoreToStg.Prep. The tick does not satisfy tickishIsCode;
987 the inlining-in-CorePrep happens for cpExprIsTrivial which tests
988 tickishIsCode.
989
990 So we test the same thing here, pushing any non-code ticks to
991 the top (they don't generate any code, after all). This showed
992 up in the fallout from fixing #19360.
993 -}
994
995 stgArity :: Id -> HowBound -> Arity
996 stgArity _ (LetBound _ arity) = arity
997 stgArity f ImportBound = idArity f
998 stgArity _ LambdaBound = 0