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