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