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