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