CoreToStg.lhs 44.5 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
%
4
\section[CoreToStg]{Converts Core to STG Syntax}
5

6 7
And, as we have the info in hand, we may convert some lets to
let-no-escapes.
8 9

\begin{code}
10
module CoreToStg ( coreToStg, coreExprToStg ) where
11

12
#include "HsVersions.h"
13

14
import CoreSyn
15 16
import CoreUtils        ( exprType, findDefault )
import CoreArity        ( manifestArity )
17
import StgSyn
18

19
import Type
20
import TyCon
21
import MkId             ( coercionTokenId )
22 23 24
import Id
import IdInfo
import DataCon
25
import CostCentre       ( noCCS )
26
import VarSet
27
import VarEnv
28
import Maybes           ( maybeToBool )
29
import Module
30 31
import Name             ( getOccName, isExternalName, nameOccName )
import OccName          ( occNameString, occNameFS )
32
import BasicTypes       ( Arity )
33
import TysWiredIn       ( unboxedUnitDataCon )
34
import Literal
35
import Outputable
twanvl's avatar
twanvl committed
36
import MonadUtils
37
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
38
import Util
Ian Lynagh's avatar
Ian Lynagh committed
39
import DynFlags
40
import ForeignCall
41
import PrimOp           ( PrimCall(..) )
42 43
\end{code}

44
%************************************************************************
45
%*                                                                      *
46
\subsection[live-vs-free-doc]{Documentation}
47
%*                                                                      *
48 49
%************************************************************************

50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
(There is other relevant documentation in codeGen/CgLetNoEscape.)

The actual Stg datatype is decorated with {\em live variable}
information, as well as {\em free variable} information.  The two are
{\em not} the same.  Liveness is an operational property rather than a
semantic one.  A variable is live at a particular execution point if
it can be referred to {\em directly} again.  In particular, a dead
variable's stack slot (if it has one):
\begin{enumerate}
\item
should be stubbed to avoid space leaks, and
\item
may be reused for something else.
\end{enumerate}

There ought to be a better way to say this.  Here are some examples:
\begin{verbatim}
67 68 69
        let v = [q] \[x] -> e
        in
        ...v...  (but no q's)
70 71
\end{verbatim}

72
Just after the `in', v is live, but q is dead.  If the whole of that
73 74
let expression was enclosed in a case expression, thus:
\begin{verbatim}
75 76
        case (let v = [q] \[x] -> e in ...v...) of
                alts[...q...]
77 78 79 80 81 82
\end{verbatim}
(ie @alts@ mention @q@), then @q@ is live even after the `in'; because
we'll return later to the @alts@ and need it.

Let-no-escapes make this a bit more interesting:
\begin{verbatim}
83 84 85
        let-no-escape v = [q] \ [x] -> e
        in
        ...v...
86 87 88 89 90 91
\end{verbatim}
Here, @q@ is still live at the `in', because @v@ is represented not by
a closure but by the current stack state.  In other words, if @v@ is
live then so is @q@.  Furthermore, if @e@ mentions an enclosing
let-no-escaped variable, then {\em its} free variables are also live
if @v@ is.
92

93
%************************************************************************
94
%*                                                                      *
95
\subsection[caf-info]{Collecting live CAF info}
96
%*                                                                      *
97 98
%************************************************************************

99 100
In this pass we also collect information on which CAFs are live for
constructing SRTs (see SRT.lhs).
101 102 103

A top-level Id has CafInfo, which is

104 105 106
        - MayHaveCafRefs, if it may refer indirectly to
          one or more CAFs, or
        - NoCafRefs if it definitely doesn't
107

108
The CafInfo has already been calculated during the CoreTidy pass.
109 110 111 112 113 114 115 116 117 118

During CoreToStg, we then pin onto each binding and case expression, a
list of Ids which represents the "live" CAFs at that point.  The meaning
of "live" here is the same as for live variables, see above (which is
why it's convenient to collect CAF information here rather than elsewhere).

The later SRT pass takes these lists of Ids and uses them to construct
the actual nested SRTs, and replaces the lists of Ids with (offset,length)
pairs.

119 120 121 122 123

Interaction of let-no-escape with SRTs   [Sept 01]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

124 125 126
        let-no-escape x = ...caf1...caf2...
        in
        ...x...x...x...
127

128
where caf1,caf2 are CAFs.  Since x doesn't have a closure, we
129 130 131 132 133 134 135 136 137
build SRTs just as if x's defn was inlined at each call site, and
that means that x's CAF refs get duplicated in the overall SRT.

This is unlike ordinary lets, in which the CAF refs are not duplicated.

We could fix this loss of (static) sharing by making a sort of pseudo-closure
for x, solely to put in the SRTs lower down.


138
%************************************************************************
139
%*                                                                      *
140
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
141
%*                                                                      *
142 143 144
%************************************************************************

\begin{code}
145 146
coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
coreToStg dflags this_mod pgm
147
  = return pgm'
148
  where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
149 150

coreExprToStg :: CoreExpr -> StgExpr
151
coreExprToStg expr
152 153 154 155
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Ian Lynagh's avatar
Ian Lynagh committed
156
    :: DynFlags
157
    -> Module
158
    -> IdEnv HowBound           -- environment for the bindings
159
    -> CoreProgram
160 161
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

162 163
coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags this_mod env (b:bs)
164
  = (env2, fvs2, b':bs')
165
  where
166 167 168
        -- Notice the mutually-recursive "knot" here:
        --   env accumulates down the list of binds,
        --   fvs accumulates upwards
169 170
        (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
        (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
171 172

coreTopBindToStg
Ian Lynagh's avatar
Ian Lynagh committed
173
        :: DynFlags
174
        -> Module
175 176 177 178
        -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
179

180
coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
181 182 183
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
184

185 186
        (stg_rhs, fvs') =
            initLne env $ do
187
              (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
twanvl's avatar
twanvl committed
188
              return (stg_rhs, fvs')
189 190

        bind = StgNonRec id stg_rhs
191
    in
192 193 194 195 196
    ASSERT2(consistentCafInfo id bind, ppr id )
      -- NB: previously the assertion printed 'rhs' and 'bind'
      --     as well as 'id', but that led to a black hole
      --     where printing the assertion error tripped the
      --     assertion again!
197 198
    (env', fvs' `unionFVInfo` body_fvs, bind)

199
coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
200
  = ASSERT( not (null pairs) )
201 202
    let
        binders = map fst pairs
203

204 205 206
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
207

208
        (stg_rhss, fvs')
209
          = initLne env' $ do
210
               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
211 212
               let fvs' = unionFVInfos fvss'
               return (stg_rhss, fvs')
213

214
        bind = StgRec (zip binders stg_rhss)
215
    in
216
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
217 218
    (env', fvs' `unionFVInfo` body_fvs, bind)

219

220 221 222 223
-- Assertion helper: this checks that the CafInfo on the Id matches
-- what CoreToStg has figured out about the binding's SRT.  The
-- CafInfo will be exact in all cases except when CorePrep has
-- floated out a binding, in which case it will be approximate.
Ian Lynagh's avatar
Ian Lynagh committed
224
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
225
consistentCafInfo id bind
226
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
227
    safe
228
  where
229 230 231 232 233
    safe  = id_marked_caffy || not binding_is_caffy
    exact = id_marked_caffy == binding_is_caffy
    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
    binding_is_caffy = stgBindHasCafRefs bind
    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
234 235 236
\end{code}

\begin{code}
237
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
238
        :: DynFlags
239
        -> Module
240 241 242
        -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
243

244
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
245 246 247
  = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
       ; lv_info <- freeVarsToLiveVars rhs_fvs

248
       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr_info new_rhs
249
             stg_arity = stgRhsArity stg_rhs
250
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
251
                 rhs_fvs) }
252
  where
253
    bndr_info = lookupFVInfo scope_fv_info bndr
254

255 256 257 258 259 260 261 262 263 264
        -- It's vital that the arity on a top-level Id matches
        -- the arity of the generated STG binding, else an importing
        -- module will use the wrong calling convention
        --      (Trac #2844 was an example where this happened)
        -- NB1: we can't move the assertion further out without
        --      blocking the "knot" tied in coreTopBindsToStg
        -- NB2: the arity check is only needed for Ids with External
        --      Names, because they are externally visible.  The CorePrep
        --      pass introduces "sat" things with Local Names and does
        --      not bother to set their Arity info, so don't fail for those
265 266
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
267
       | otherwise                    = True
268 269
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
270
        = vcat [ppr bndr,
271 272 273
                ptext (sLit "Id arity:") <+> ppr id_arity,
                ptext (sLit "STG arity:") <+> ppr stg_arity]

274
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
275 276
            -> SRT -> StgBinderInfo -> StgExpr
            -> StgRhs
277

278
mkTopStgRhs _ _ rhs_fvs srt binder_info (StgLam bndrs body)
279
  = StgRhsClosure noCCS binder_info
280 281 282 283
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt
                  bndrs body
284

285 286
mkTopStgRhs dflags this_mod _ _ _ (StgConApp con args)
  | not (isDllConApp dflags this_mod con args)  -- Dynamic StgConApps are updatable
287 288
  = StgRhsCon noCCS con args

289
mkTopStgRhs _ _ rhs_fvs srt binder_info rhs
290
  = StgRhsClosure noCCS binder_info
291 292 293 294
                  (getFVs rhs_fvs)
                  Updatable
                  srt
                  [] rhs
295
\end{code}
296 297 298 299 300


-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
301

302
\begin{code}
303
coreToStgExpr
304 305 306 307 308 309 310 311
        :: CoreExpr
        -> LneM (StgExpr,       -- Decorated STG expr
                 FreeVarsInfo,  -- Its free vars (NB free, not live)
                 EscVarsSet)    -- Its escapees, a subset of its free vars;
                                -- also a subset of the domain of the envt
                                -- because we are only interested in the escapees
                                -- for vars which might be turned into
                                -- let-no-escaped ones.
312 313
\end{code}

314 315 316 317 318
The second and third components can be derived in a simple bottom up pass, not
dependent on any decisions about which variables will be let-no-escaped or
not.  The first component, that is, the decorated expression, may then depend
on these components, but it in turn is not scrutinised as the basis for any
decisions.  Hence no black holes.
319 320

\begin{code}
321 322
-- No LitInteger's should be left by the time this is called. CorePrep
-- should have converted them all to a real core representation.
323
coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
324 325 326
coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v)      = coreToStgApp Nothing v               []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
sof's avatar
sof committed
327

328
coreToStgExpr expr@(App _ _)
329 330 331
  = coreToStgApp Nothing f args
  where
    (f, args) = myCollectArgs expr
332

333
coreToStgExpr expr@(Lam _ _)
334
  = let
335 336
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
337
    in
twanvl's avatar
twanvl committed
338 339
    extendVarEnvLne [ (a, LambdaBound) | a <- args' ] $ do
    (body, body_fvs, body_escs) <- coreToStgExpr body
340
    let
341 342 343
        fvs             = args' `minusFVBinders` body_fvs
        escs            = body_escs `delVarSetList` args'
        result_expr | null args' = body
344
                    | otherwise  = StgLam args' body
345

twanvl's avatar
twanvl committed
346 347
    return (result_expr, fvs, escs)

348 349 350
coreToStgExpr (Tick (HpcTick m n) expr)
  = do (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgTick m n expr2, fvs, escs)
351

352 353 354
coreToStgExpr (Tick (ProfNote cc tick push) expr)
  = do (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgSCC cc tick push expr2, fvs, escs)
andy@galois.com's avatar
andy@galois.com committed
355

356 357
coreToStgExpr (Tick Breakpoint{} _expr)
  = panic "coreToStgExpr: breakpoint should not happen"
358

Ian Lynagh's avatar
Ian Lynagh committed
359
coreToStgExpr (Cast expr _)
360 361
  = coreToStgExpr expr

362 363
-- Cases require a little more real work.

364 365
coreToStgExpr (Case scrut _ _ [])
  = coreToStgExpr scrut
366 367 368 369 370 371 372 373
    -- See Note [Empty case alternatives] in CoreSyn If the case
    -- alternatives are empty, the scrutinee must diverge or raise an
    -- exception, so we can just dive into it.
    --
    -- Of course this may seg-fault if the scrutinee *does* return.  A
    -- belt-and-braces approach would be to move this case into the
    -- code generator, and put a return point anyway that calls a
    -- runtime system error function.
374

375

twanvl's avatar
twanvl committed
376 377 378 379 380 381 382
coreToStgExpr (Case scrut bndr _ alts) = do
    (alts2, alts_fvs, alts_escs)
       <- extendVarEnvLne [(bndr, LambdaBound)] $ do
            (alts2, fvs_s, escs_s) <- mapAndUnzip3M vars_alt alts
            return ( alts2,
                     unionFVInfos fvs_s,
                     unionVarSets escs_s )
383
    let
384 385 386 387 388 389 390 391 392 393 394
        -- Determine whether the default binder is dead or not
        -- This helps the code generator to avoid generating an assignment
        -- for the case binder (is extremely rare cases) ToDo: remove.
        bndr' | bndr `elementOfFVInfo` alts_fvs = bndr
              | otherwise                       = bndr `setIdOccInfo` IAmDead

        -- Don't consider the default binder as being 'live in alts',
        -- since this is from the point of view of the case expr, where
        -- the default binder is not free.
        alts_fvs_wo_bndr  = bndr `minusFVBinder` alts_fvs
        alts_escs_wo_bndr = alts_escs `delVarSet` bndr
395

twanvl's avatar
twanvl committed
396
    alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
397

398 399
        -- We tell the scrutinee that everything
        -- live in the alts is live in it, too.
Ian Lynagh's avatar
Ian Lynagh committed
400
    (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
twanvl's avatar
twanvl committed
401 402 403 404 405 406
       <- setVarsLiveInCont alts_lv_info $ do
            (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
            scrut_lv_info <- freeVarsToLiveVars scrut_fvs
            return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)

    return (
407
      StgCase scrut2 (getLiveVars scrut_lv_info)
408 409 410 411 412
                     (getLiveVars alts_lv_info)
                     bndr'
                     (mkSRT alts_lv_info)
                     (mkStgAltType bndr alts)
                     alts2,
413 414
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
415 416 417
                -- You might think we should have scrut_escs, not
                -- (getFVSet scrut_fvs), but actually we can't call, and
                -- then return from, a let-no-escape thing.
418 419
      )
  where
420
    vars_alt (con, binders, rhs)
421
      | DataAlt c <- con, c == unboxedUnitDataCon
422
      = -- This case is a bit smelly.
423 424 425 426 427 428
        -- See Note [Nullary unboxed tuple] in Type.lhs
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
           ; return ((DEFAULT, [], [], rhs2), rhs_fvs, rhs_escs) }
      | otherwise
429 430 431
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
twanvl's avatar
twanvl committed
432 433
        extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
        (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
434
        let
435 436
                -- Records whether each param is used in the RHS
            good_use_mask = [ b `elementOfFVInfo` rhs_fvs | b <- binders' ]
twanvl's avatar
twanvl committed
437 438 439 440

        return ( (con, binders', good_use_mask, rhs2),
                 binders' `minusFVBinders` rhs_fvs,
                 rhs_escs `delVarSetList` binders' )
441 442
                -- ToDo: remove the delVarSet;
                -- since escs won't include any of these binders
443 444
\end{code}

445 446
Lets not only take quite a bit of work, but this is where we convert
then to let-no-escapes, if we wish.
447

448
(Meanwhile, we don't expect to see let-no-escapes...)
449
\begin{code}
twanvl's avatar
twanvl committed
450 451 452 453 454
coreToStgExpr (Let bind body) = do
    (new_let, fvs, escs, _)
       <- mfix (\ ~(_, _, _, no_binder_escapes) ->
             coreToStgLet no_binder_escapes bind body
          )
455

twanvl's avatar
twanvl committed
456
    return (new_let, fvs, escs)
Ian Lynagh's avatar
Ian Lynagh committed
457 458

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
459 460
\end{code}

461
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
462
mkStgAltType :: Id -> [CoreAlt] -> AltType
463 464 465 466 467 468 469 470 471
mkStgAltType bndr alts = case repType (idType bndr) of
    UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
        Just tc | isUnLiftedTyCon tc -> PrimAlt tc
                | isAbstractTyCon tc -> look_for_better_tycon
                | isAlgTyCon tc      -> AlgAlt tc
                | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                        PolyAlt
        Nothing                      -> PolyAlt
    UbxTupleRep rep_tys -> UbxTupAlt (length rep_tys)
472
    -- NB Nullary unboxed tuples have UnaryRep, and generate a PrimAlt
473
  where
474
   _is_poly_alt_tycon tc
475
        =  isFunTyCon tc
476
        || isPrimTyCon tc   -- "Any" is lifted but primitive
477
        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
478 479
                            -- function application where argument has a
                            -- type-family type
480

481 482
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
483
   -- grabbing the one from a constructor alternative
484 485
   -- if one exists.
   look_for_better_tycon
486 487 488 489 490 491 492
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
493 494
\end{code}

495

496 497 498 499
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

500
\begin{code}
501
coreToStgApp
502 503 504 505 506 507 508
         :: Maybe UpdateFlag            -- Just upd <=> this application is
                                        -- the rhs of a thunk binding
                                        --      x = [...] \upd [] -> the_app
                                        -- with specified update flag
        -> Id                           -- Function
        -> [CoreArg]                    -- Arguments
        -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
509

510

Ian Lynagh's avatar
Ian Lynagh committed
511
coreToStgApp _ f args = do
twanvl's avatar
twanvl committed
512 513
    (args', args_fvs) <- coreToStgArgs args
    how_bound <- lookupVarLne f
514 515

    let
516 517 518 519
        n_val_args       = valArgCount args
        not_letrec_bound = not (isLetBound how_bound)
        fun_fvs = singletonFVInfo f how_bound fun_occ
            -- e.g. (f :: a -> int) (x :: a)
520 521 522
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively

523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565
        -- Mostly, the arity info of a function is in the fn's IdInfo
        -- But new bindings introduced by CoreSat may not have no
        -- arity info; it would do us no good anyway.  For example:
        --      let f = \ab -> e in f
        -- No point in having correct arity info for f!
        -- Hence the hasArity stuff below.
        -- NB: f_arity is only consulted for LetBound things
        f_arity   = stgArity f how_bound
        saturated = f_arity <= n_val_args

        fun_occ
         | not_letrec_bound         = noBinderInfo      -- Uninteresting variable
         | f_arity > 0 && saturated = stgSatOcc -- Saturated or over-saturated function call
         | otherwise                = stgUnsatOcc       -- Unsaturated function or thunk

        fun_escs
         | not_letrec_bound      = emptyVarSet  -- Only letrec-bound escapees are interesting
         | f_arity == n_val_args = emptyVarSet  -- A function *or thunk* with an exactly
                                                -- saturated call doesn't escape
                                                -- (let-no-escape applies to 'thunks' too)

         | otherwise         = unitVarSet f     -- Inexact application; it does escape

        -- At the moment of the call:

        --  either the function is *not* let-no-escaped, in which case
        --         nothing is live except live_in_cont
        --      or the function *is* let-no-escaped in which case the
        --         variables it uses are live, but still the function
        --         itself is not.  PS.  In this case, the function's
        --         live vars should already include those of the
        --         continuation, but it does no harm to just union the
        --         two regardless.

        res_ty = exprType (mkApps (Var f) args)
        app = case idDetails f of
                DataConWorkId dc | saturated -> StgConApp dc args'

                -- Some primitive operator that might be implemented as a library call.
                PrimOpId op      -> ASSERT( saturated )
                                    StgOpApp (StgPrimOp op) args' res_ty

                -- A call to some primitive Cmm function.
566
                FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
567 568 569 570 571 572
                                 -> ASSERT( saturated )
                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty

                -- A regular foreign call.
                FCallId call     -> ASSERT( saturated )
                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
573

574
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
575
                _other           -> StgApp f args'
576 577
        fvs = fun_fvs  `unionFVInfo` args_fvs
        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
578 579
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
580

581 582
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
583 584 585 586
    app `seq` fvs `seq` seqVarSet vars `seq` return (
        app,
        fvs,
        vars
twanvl's avatar
twanvl committed
587
     )
588 589


590 591 592 593 594 595 596 597

-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
coreToStgArgs []
twanvl's avatar
twanvl committed
598
  = return ([], emptyFVInfo)
599

Ian Lynagh's avatar
Ian Lynagh committed
600
coreToStgArgs (Type _ : args) = do     -- Type argument
twanvl's avatar
twanvl committed
601
    (args', fvs) <- coreToStgArgs args
602
    return (args', fvs)
603

604 605 606 607
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
  = do { (args', fvs) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', fvs) }

twanvl's avatar
twanvl committed
608 609
coreToStgArgs (arg : args) = do         -- Non-type argument
    (stg_args, args_fvs) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
610
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
611
    let
612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627
        fvs = args_fvs `unionFVInfo` arg_fvs
        stg_arg = case arg' of
                       StgApp v []      -> StgVarArg v
                       StgConApp con [] -> StgVarArg (dataConWorkId con)
                       StgLit lit       -> StgLitArg lit
                       _                -> pprPanic "coreToStgArgs" (ppr arg)

        -- WARNING: what if we have an argument like (v `cast` co)
        --          where 'co' changes the representation type?
        --          (This really only happens if co is unsafe.)
        -- Then all the getArgAmode stuff in CgBindery will set the
        -- cg_rep of the CgIdInfo based on the type of v, rather
        -- than the type of 'co'.
        -- This matters particularly when the function is a primop
        -- or foreign call.
        -- Wanted: a better solution than this hacky warning
628
    let
629 630 631
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
        bad_args = (isUnLiftedType arg_ty && not (isUnLiftedType stg_arg_ty))
632 633
                || (map typePrimRep (flattenRepType (repType arg_ty))
                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
634 635 636 637 638
        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
        -- we can treat an unlifted value as lifted.  But the other way round
        -- we complain.
        -- We also want to check if a pointer is cast to a non-ptr etc
twanvl's avatar
twanvl committed
639

Ian Lynagh's avatar
Ian Lynagh committed
640
    WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
twanvl's avatar
twanvl committed
641
     return (stg_arg : stg_args, fvs)
642 643


644 645 646 647 648
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
649 650 651 652 653 654 655 656
         :: Bool        -- True <=> yes, we are let-no-escaping this let
         -> CoreBind    -- bindings
         -> CoreExpr    -- body
         -> LneM (StgExpr,      -- new let
                  FreeVarsInfo, -- variables free in the whole let
                  EscVarsSet,   -- variables that escape from the whole let
                  Bool)         -- True <=> none of the binders in the bindings
                                -- is among the escaping vars
657

twanvl's avatar
twanvl committed
658 659 660 661
coreToStgLet let_no_escape bind body = do
    (bind2, bind_fvs, bind_escs, bind_lvs,
     body2, body_fvs, body_escs, body_lvs)
       <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
662

twanvl's avatar
twanvl committed
663 664 665 666
          -- Do the bindings, setting live_in_cont to empty if
          -- we ain't in a let-no-escape world
          live_in_cont <- getVarsLiveInCont
          ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
667 668
                <- setVarsLiveInCont (if let_no_escape
                                          then live_in_cont
twanvl's avatar
twanvl committed
669 670
                                          else emptyLiveInfo)
                                     (vars_bind rec_body_fvs bind)
671

twanvl's avatar
twanvl committed
672 673 674 675
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
             body_lv_info <- freeVarsToLiveVars body_fvs
676

twanvl's avatar
twanvl committed
677 678
             return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
                     body2, body_fvs, body_escs, getLiveVars body_lv_info)
679 680


681
        -- Compute the new let-expression
682
    let
683 684
        new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
                | otherwise     = StgLet bind2 body2
685

686 687
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
688

689 690
        live_in_whole_let
          = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
691

692 693 694 695 696
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
697

698
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
699

700 701
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
702

703
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
704

705 706 707 708 709 710 711 712 713
        -- Debugging code as requested by Andrew Kennedy
        checked_no_binder_escapes
                | debugIsOn && not no_binder_escapes && any is_join_var binders
                = pprTrace "Interesting!  A join var that isn't let-no-escaped" (ppr binders)
                  False
                | otherwise = no_binder_escapes

                -- Mustn't depend on the passed-in let_no_escape flag, since
                -- no_binder_escapes is used by the caller to derive the flag!
twanvl's avatar
twanvl committed
714
    return (
715 716 717 718
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
719
      )
720
  where
721
    set_of_binders = mkVarSet binders
722
    binders        = bindersOf bind
723

724
    mk_binding bind_lv_info binder rhs
725 726 727 728 729 730 731 732 733 734 735 736 737 738
        = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
        where
           live_vars | let_no_escape = addLiveVar bind_lv_info binder
                     | otherwise     = unitLiveVar binder
                -- c.f. the invariant on NestedLet

    vars_bind :: FreeVarsInfo           -- Free var info for body of binding
              -> CoreBind
              -> LneM (StgBinding,
                       FreeVarsInfo,
                       EscVarsSet,        -- free vars; escapee vars
                       LiveInfo,          -- Vars and CAFs live in binding
                       [(Id, HowBound)])  -- extension to environment

739

twanvl's avatar
twanvl committed
740 741
    vars_bind body_fvs (NonRec binder rhs) = do
        (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
742 743
        let
            env_ext_item = mk_binding bind_lv_info binder rhs
twanvl's avatar
twanvl committed
744

745 746
        return (StgNonRec binder rhs2,
                bind_fvs, escs, bind_lv_info, [env_ext_item])
747 748 749


    vars_bind body_fvs (Rec pairs)
twanvl's avatar
twanvl committed
750
      = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766
           let
                rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
                binders = map fst pairs
                env_ext = [ mk_binding bind_lv_info b rhs
                          | (b,rhs) <- pairs ]
           in
           extendVarEnvLne env_ext $ do
              (rhss2, fvss, lv_infos, escss)
                     <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
              let
                        bind_fvs = unionFVInfos fvss
                        bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
                        escs     = unionVarSets escss

              return (StgRec (binders `zip` rhss2),
                      bind_fvs, escs, bind_lv_info, env_ext)
twanvl's avatar
twanvl committed
767

768 769 770 771

is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
772
is_join_var j = occNameString (getOccName j) == "$j"
773
\end{code}
774

775
\begin{code}
776 777 778 779
coreToStgRhs :: FreeVarsInfo            -- Free var info for the scope of the binding
             -> [Id]
             -> (Id,CoreExpr)
             -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
780

twanvl's avatar
twanvl committed
781 782 783 784 785
coreToStgRhs scope_fv_info binders (bndr, rhs) = do
    (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
    lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
    return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs,
            rhs_fvs, lv_info, rhs_escs)
786 787 788
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

789
mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
790

Ian Lynagh's avatar
Ian Lynagh committed
791
mkStgRhs _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
792

793
mkStgRhs rhs_fvs srt binder_info (StgLam bndrs body)
794
  = StgRhsClosure noCCS binder_info
795 796 797 798
                  (getFVs rhs_fvs)
                  ReEntrant
                  srt bndrs body

799
mkStgRhs rhs_fvs srt binder_info rhs
800
  = StgRhsClosure noCCS binder_info
801 802
                  (getFVs rhs_fvs)
                  upd_flag srt [] rhs
803
  where
804 805 806 807 808 809
   upd_flag = Updatable
  {-
    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
    well; and making these into simple non-updatable thunks breaks other
    assumptions (namely that they will be entered only once).

810
    upd_flag | isPAP env rhs  = ReEntrant
811
             | otherwise      = Updatable
812 813
  -}

814 815
{- ToDo:
          upd = if isOnceDem dem
816 817 818
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
819
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
820
                     Updatable)
821
                else Updatable
822 823 824 825
        -- For now we forbid SingleEntry CAFs; they tickle the
        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
        -- and I don't understand why.  There's only one SE_CAF (well,
        -- only one that tickled a great gaping bug in an earlier attempt
826
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
827 828 829 830 831 832 833 834 835 836
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}
\end{code}

Detect thunks which will reduce immediately to PAPs, and make them
non-updatable.  This has several advantages:

        - the non-updatable thunk behaves exactly like the PAP,

837 838
        - the thunk is more efficient to enter, because it is
          specialised to the task.
839 840

        - we save one update frame, one stg_update_PAP, one update
841
          and lots of PAP_enters.
842

843 844 845
        - in the case where the thunk is top-level, we save building
          a black hole and futhermore the thunk isn't considered to
          be a CAF any more, so it doesn't appear in any SRTs.
846 847 848 849 850 851

We do it here, because the arity information is accurate, and we need
to do it before the SRT pass to save the SRT entries associated with
any top-level PAPs.

isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
852 853 854
                          where
                            arity = stgArity f (lookupBinding env f)
isPAP env _               = False
855

856

857
%************************************************************************
858
%*                                                                      *
859
\subsection[LNE-monad]{A little monad for this let-no-escaping pass}
860
%*                                                                      *
861 862
%************************************************************************

863
There's a lot of stuff to pass around, so we use this @LneM@ monad to
864
help.  All the stuff here is only passed *down*.
865

866
\begin{code}
twanvl's avatar
twanvl committed
867 868 869 870 871
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> LiveInfo                -- Vars and CAFs live in continuation
             -> a
    }
872

873 874 875 876
type LiveInfo = (StgLiveVars,   -- Dynamic live variables;
                                -- i.e. ones with a nested (non-top-level) binding
                 CafSet)        -- Static live variables;
                                -- i.e. top-level variables that are CAFs or refer to them
877 878 879 880

type EscVarsSet = IdSet
type CafSet     = IdSet

881
data HowBound
882 883
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
884

885 886 887
  | LetBound            -- A let(rec) in this module
        LetInfo         -- Whether top level or nested
        Arity           -- Its arity (local Ids don't have arity info at this point)
888

889
  | LambdaBound         -- Used for both lambda and case
890

891
data LetInfo
892 893 894 895 896
  = TopLet              -- top level things
  | NestedLet LiveInfo  -- For nested things, what is live if this
                        -- thing is live?  Invariant: the binder
                        -- itself is always a member of
                        -- the dynamic set of its own LiveInfo
897

Ian Lynagh's avatar
Ian Lynagh committed
898
isLetBound :: HowBound -> Bool
899
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
900
isLetBound _              = False
901

Ian Lynagh's avatar
Ian Lynagh committed
902 903
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
904
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
905
topLevelBound _                   = False
906 907
\end{code}

908 909
For a let(rec)-bound variable, x, we record LiveInfo, the set of
variables that are live if x is live.  This LiveInfo comprises
910 911
        (a) dynamic live variables (ones with a non-top-level binding)
        (b) static live variabes (CAFs or things that refer to CAFs)
912

913 914 915 916 917 918 919
For "normal" variables (a) is just x alone.  If x is a let-no-escaped
variable then x is represented by a code pointer and a stack pointer
(well, one for each stack).  So all of the variables needed in the
execution of x are live if x is, and are therefore recorded in the
LetBound constructor; x itself *is* included.

The set of dynamic live variables is guaranteed ot have no further let-no-escaped
920
variables in it.
921

922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945
\begin{code}
emptyLiveInfo :: LiveInfo
emptyLiveInfo = (emptyVarSet,emptyVarSet)

unitLiveVar :: Id -> LiveInfo
unitLiveVar lv = (unitVarSet lv, emptyVarSet)

unitLiveCaf :: Id -> LiveInfo
unitLiveCaf caf = (emptyVarSet, unitVarSet caf)

addLiveVar :: LiveInfo -> Id -> LiveInfo
addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)

unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)

mkSRT :: LiveInfo -> SRT
mkSRT (_, cafs) = SRTEntries cafs

getLiveVars :: LiveInfo -> StgLiveVars
getLiveVars (lvs, _) = lvs
\end{code}


946 947
The std monad functions:
\begin{code}
948
initLne :: IdEnv HowBound -> LneM a -> a
twanvl's avatar
twanvl committed
949
initLne env m = unLneM m env emptyLiveInfo
950

951

952 953 954 955 956

{-# INLINE thenLne #-}
{-# INLINE returnLne #-}

returnLne :: a -> LneM a
Ian Lynagh's avatar
Ian Lynagh committed
957
returnLne e = LneM $ \_ _ -> e
958 959

thenLne :: LneM a -> (a -> LneM b) -> LneM b
twanvl's avatar
twanvl committed
960 961 962 963 964 965 966 967 968 969 970
thenLne m k = LneM $ \env lvs_cont
  -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont

instance Monad LneM where
    return = returnLne
    (>>=)  = thenLne

instance MonadFix LneM where
    mfix expr = LneM $ \env lvs_cont ->
                       let result = unLneM (expr result) env lvs_cont
                       in  result
971
\end{code}
972

973
Functions specific to this monad:
974

975
\begin{code}
976
getVarsLiveInCont :: LneM LiveInfo
Ian Lynagh's avatar
Ian Lynagh committed
977
getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
978

979
setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
twanvl's avatar
twanvl committed
980
setVarsLiveInCont new_lvs_cont expr
Ian Lynagh's avatar
Ian Lynagh committed
981
   =    LneM $   \env _lvs_cont
twanvl's avatar
twanvl committed
982
   -> unLneM expr env new_lvs_cont
simonmar's avatar