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