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