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