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