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