CoreToStg.hs 39.6 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

Jan Stolarek's avatar
Jan Stolarek committed
3 4 5
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--
6

Jan Stolarek's avatar
Jan Stolarek committed
7 8 9 10 11 12
--------------------------------------------------------------
-- Converting Core to STG Syntax
--------------------------------------------------------------

-- And, as we have the info in hand, we may convert some lets to
-- let-no-escapes.
13

14
module CoreToStg ( coreToStg, coreExprToStg ) where
15

16
#include "HsVersions.h"
17

18
import CoreSyn
19 20
import CoreUtils        ( exprType, findDefault )
import CoreArity        ( manifestArity )
21
import StgSyn
22

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

Icelandjack's avatar
Icelandjack committed
47
import Data.Maybe    (isJust)
Austin Seipp's avatar
Austin Seipp committed
48 49
import Control.Monad (liftM, ap)

Jan Stolarek's avatar
Jan Stolarek committed
50 51 52
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
53 54 55 56
-- The two are 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 directly again. In particular, a dead
-- variable's stack slot (if it has one):
Jan Stolarek's avatar
Jan Stolarek committed
57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
--
--           - should be stubbed to avoid space leaks, and
--           - may be reused for something else.
--
-- There ought to be a better way to say this. Here are some examples:
--
--         let v = [q] \[x] -> e
--         in
--         ...v...  (but no q's)
--
-- Just after the `in', v is live, but q is dead. If the whole of that
-- let expression was enclosed in a case expression, thus:
--
--         case (let v = [q] \[x] -> e in ...v...) of
--                 alts[...q...]
--
-- (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:
--
--         let-no-escape v = [q] \ [x] -> e
--         in
--         ...v...
--
-- 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 its free variables are also live if `v' is.

-- Note [Collecting live CAF info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
90
-- In this pass we also collect information on which CAFs are live.
Jan Stolarek's avatar
Jan Stolarek committed
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
--
-- A top-level Id has CafInfo, which is
--
--         - MayHaveCafRefs, if it may refer indirectly to
--           one or more CAFs, or
--         - NoCafRefs if it definitely doesn't
--
-- The CafInfo has already been calculated during the CoreTidy pass.
--
-- 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.

-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider:
--
--     let x = fvs \ args -> e
--     in
--         if ... then x else
--            if ... then x else ...
--
-- `x' is used twice (so we probably can't unfold it), but when it is
-- entered, the stack is deeper than it was when the definition of `x'
-- happened.  Specifically, if instead of allocating a closure for `x',
-- we saved all `x's fvs on the stack, and remembered the stack depth at
-- that moment, then whenever we enter `x' we can simply set the stack
-- pointer(s) to these remembered (compile-time-fixed) values, and jump
-- to the code for `x'.
--
-- All of this is provided x is:
Jan Stolarek's avatar
Jan Stolarek committed
128 129
--   1. non-updatable - it must have at least one parameter (see Note
--      [Join point abstraction]);
Jan Stolarek's avatar
Jan Stolarek committed
130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
--   2. guaranteed to be entered before the stack retreats -- ie x is not
--      buried in a heap-allocated closure, or passed as an argument to
--      something;
--   3. all the enters have exactly the right number of arguments,
--      no more no less;
--   4. all the enters are tail calls; that is, they return to the
--      caller enclosing the definition of `x'.
--
-- Under these circumstances we say that `x' is non-escaping.
--
-- An example of when (4) does not hold:
--
--     let x = ...
--     in case x of ...alts...
--
-- Here, `x' is certainly entered only when the stack is deeper than when
-- `x' is defined, but here it must return to ...alts... So we can't just
-- adjust the stack down to `x''s recalled points, because that would lost
-- alts' context.
--
-- Things can get a little more complicated.  Consider:
--
--     let y = ...
--     in let x = fvs \ args -> ...y...
--     in ...x...
--
-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
-- non-escaping way in ...y..., then `y' is non-escaping.
--
-- `x' can even be recursive!  Eg:
--
--     letrec x = [y] \ [v] -> if v then x True else ...
--     in
--         ...(x b)...

-- --------------------------------------------------------------
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
168

169
coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
170
coreToStg dflags this_mod pgm
171
  = pgm'
172
  where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
173 174

coreExprToStg :: CoreExpr -> StgExpr
175
coreExprToStg expr
176 177 178 179
  = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)


coreTopBindsToStg
Ian Lynagh's avatar
Ian Lynagh committed
180
    :: DynFlags
181
    -> Module
182
    -> IdEnv HowBound           -- environment for the bindings
183
    -> CoreProgram
184 185
    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])

186 187
coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])
coreTopBindsToStg dflags this_mod env (b:bs)
188
  = (env2, fvs2, b':bs')
189
  where
190 191 192
        -- Notice the mutually-recursive "knot" here:
        --   env accumulates down the list of binds,
        --   fvs accumulates upwards
193 194
        (env1, fvs2, b' ) = coreTopBindToStg dflags this_mod env fvs1 b
        (env2, fvs1, bs') = coreTopBindsToStg dflags this_mod env1 bs
195 196

coreTopBindToStg
Ian Lynagh's avatar
Ian Lynagh committed
197
        :: DynFlags
198
        -> Module
199 200 201 202
        -> IdEnv HowBound
        -> FreeVarsInfo         -- Info about the body
        -> CoreBind
        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
203

204
coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
205 206 207
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
208

209 210
        (stg_rhs, fvs') =
            initLne env $ do
211
              (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
twanvl's avatar
twanvl committed
212
              return (stg_rhs, fvs')
213 214

        bind = StgNonRec id stg_rhs
215
    in
216 217 218 219 220
    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!
221 222
    (env', fvs' `unionFVInfo` body_fvs, bind)

223
coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
224
  = ASSERT( not (null pairs) )
225 226
    let
        binders = map fst pairs
227

228 229 230
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
231

232
        (stg_rhss, fvs')
233
          = initLne env' $ do
234
               (stg_rhss, fvss') <- mapAndUnzipM (coreToTopStgRhs dflags this_mod body_fvs) pairs
235 236
               let fvs' = unionFVInfos fvss'
               return (stg_rhss, fvs')
237

238
        bind = StgRec (zip binders stg_rhss)
239
    in
240
    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
241 242
    (env', fvs' `unionFVInfo` body_fvs, bind)

243

244 245 246 247
-- 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
248
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
249
consistentCafInfo id bind
250
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
251
    safe
252
  where
253 254 255
    safe  = id_marked_caffy || not binding_is_caffy
    exact = id_marked_caffy == binding_is_caffy
    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
256
    binding_is_caffy = topStgBindHasCafRefs bind
257
    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
258

259
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
260
        :: DynFlags
261
        -> Module
262 263 264
        -> FreeVarsInfo         -- Free var info for the scope of the binding
        -> (Id,CoreExpr)
        -> LneM (StgRhs, FreeVarsInfo)
265

266
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
267 268
  = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs

269
       ; let stg_rhs   = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
270
             stg_arity = stgRhsArity stg_rhs
271
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
272
                 rhs_fvs) }
273
  where
274
    bndr_info = lookupFVInfo scope_fv_info bndr
275

276 277 278 279 280 281 282 283 284 285
        -- 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
286 287
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
288
       | otherwise                    = True
289 290
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
291
        = vcat [ppr bndr,
292 293
                text "Id arity:" <+> ppr id_arity,
                text "STG arity:" <+> ppr stg_arity]
294

295
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
296
            -> Id -> StgBinderInfo -> StgExpr
297
            -> StgRhs
298

299 300 301
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
        -- Dynamic StgConApps are updatable
  where con_updateable con args = isDllConApp dflags this_mod con args
302 303 304 305

-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
306

307
coreToStgExpr
308 309 310 311 312 313 314 315
        :: 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.
316

Jan Stolarek's avatar
Jan Stolarek committed
317 318 319 320 321
-- 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.
322

323 324
-- No LitInteger's should be left by the time this is called. CorePrep
-- 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 328
coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
sof's avatar
sof committed
329

330
coreToStgExpr expr@(App _ _)
331
  = coreToStgApp Nothing f args ticks
332
  where
333
    (f, args, ticks) = myCollectArgs expr
334

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

twanvl's avatar
twanvl committed
348 349
    return (result_expr, fvs, escs)

350 351 352 353 354 355 356 357
coreToStgExpr (Tick tick expr)
  = do case tick of
         HpcTick{}    -> return ()
         ProfNote{}   -> return ()
         SourceNote{} -> return ()
         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
       (expr2, fvs, escs) <- coreToStgExpr expr
       return (StgTick tick expr2, fvs, escs)
Peter Wortmann's avatar
Peter Wortmann committed
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

396 397
        -- We tell the scrutinee that everything
        -- live in the alts is live in it, too.
398
    (scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
twanvl's avatar
twanvl committed
399 400

    return (
401
      StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
402 403
      scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
      alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
404 405 406
                -- 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.
407 408
      )
  where
409
    vars_alt (con, binders, rhs)
410
      | DataAlt c <- con, c == unboxedUnitDataCon
411
      = -- This case is a bit smelly.
412
        -- See Note [Nullary unboxed tuple] in Type.hs
413 414 415
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
        do { (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
416
           ; return ((DEFAULT, [], rhs2), rhs_fvs, rhs_escs) }
417
      | otherwise
418 419 420
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
twanvl's avatar
twanvl committed
421 422
        extendVarEnvLne [(b, LambdaBound) | b <- binders'] $ do
        (rhs2, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
423
        return ( (con, binders', rhs2),
twanvl's avatar
twanvl committed
424 425
                 binders' `minusFVBinders` rhs_fvs,
                 rhs_escs `delVarSetList` binders' )
426 427
                -- ToDo: remove the delVarSet;
                -- since escs won't include any of these binders
428

Jan Stolarek's avatar
Jan Stolarek committed
429 430 431 432
-- Lets not only take quite a bit of work, but this is where we convert
-- then to let-no-escapes, if we wish.
-- (Meanwhile, we don't expect to see let-no-escapes...)

433

twanvl's avatar
twanvl committed
434 435 436 437 438
coreToStgExpr (Let bind body) = do
    (new_let, fvs, escs, _)
       <- mfix (\ ~(_, _, _, no_binder_escapes) ->
             coreToStgLet no_binder_escapes bind body
          )
439

twanvl's avatar
twanvl committed
440
    return (new_let, fvs, escs)
Ian Lynagh's avatar
Ian Lynagh committed
441 442

coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
443

Ian Lynagh's avatar
Ian Lynagh committed
444
mkStgAltType :: Id -> [CoreAlt] -> AltType
445 446
mkStgAltType bndr alts = case repType (idType bndr) of
    UnaryRep rep_ty -> case tyConAppTyCon_maybe rep_ty of
447
        Just tc | isUnliftedTyCon tc -> PrimAlt tc
448 449 450 451 452 453
                | 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)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
454
        -- UbxTupAlt includes nullary and and singleton unboxed tuples
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. Any, or arising from strict
460 461
                            -- function application where argument has a
                            -- type-family type
462

463 464
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
465
   -- grabbing the one from a constructor alternative
466 467
   -- if one exists.
   look_for_better_tycon
468 469 470 471 472 473 474
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
475

476 477 478 479
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

480
coreToStgApp
481 482 483 484 485 486
         :: 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
487
        -> [Tickish Id]                 -- Debug ticks
488
        -> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
489

490

491 492
coreToStgApp _ f args ticks = do
    (args', args_fvs, ticks') <- coreToStgArgs args
twanvl's avatar
twanvl committed
493
    how_bound <- lookupVarLne f
494 495

    let
496 497 498 499
        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)
500 501 502
            -- Here the free variables are "f", "x" AND the type variable "a"
            -- coreToStgArgs will deal with the arguments recursively

503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545
        -- 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.
546 547
                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
                                          PrimCallConv _))
548 549 550 551 552 553
                                 -> 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
554

555
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
556
                _other           -> StgApp f args'
557 558
        fvs = fun_fvs  `unionFVInfo` args_fvs
        vars = fun_escs `unionVarSet` (getFVSet args_fvs)
559 560
                                -- All the free vars of the args are disqualified
                                -- from being let-no-escaped.
561

562 563
        tapp = foldr StgTick app (ticks ++ ticks')

564 565
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
566
    app `seq` fvs `seq` seqVarSet vars `seq` return (
567
        tapp,
568 569
        fvs,
        vars
twanvl's avatar
twanvl committed
570
     )
571 572


573 574 575 576 577 578

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

579
coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo, [Tickish Id])
580
coreToStgArgs []
581
  = return ([], emptyFVInfo, [])
582

Ian Lynagh's avatar
Ian Lynagh committed
583
coreToStgArgs (Type _ : args) = do     -- Type argument
584 585
    (args', fvs, ts) <- coreToStgArgs args
    return (args', fvs, ts)
586

587
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
588 589 590 591 592 593 594
  = do { (args', fvs, ts) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', fvs, ts) }

coreToStgArgs (Tick t e : args)
  = ASSERT( not (tickishIsCode t) )
    do { (args', fvs, ts) <- coreToStgArgs (e : args)
       ; return (args', fvs, t:ts) }
595

twanvl's avatar
twanvl committed
596
coreToStgArgs (arg : args) = do         -- Non-type argument
597
    (stg_args, args_fvs, ticks) <- coreToStgArgs args
Ian Lynagh's avatar
Ian Lynagh committed
598
    (arg', arg_fvs, _escs) <- coreToStgExpr arg
599
    let
600
        fvs = args_fvs `unionFVInfo` arg_fvs
601 602 603

        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
        stg_arg = case arg'' of
604 605 606 607 608 609 610 611 612 613 614 615 616 617
                       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
618
    let
619 620
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
621
        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
622 623
                || (map typePrimRep (flattenRepType (repType arg_ty))
                        /= map typePrimRep (flattenRepType (repType stg_arg_ty)))
624 625 626 627 628
        -- 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
629

630
    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
631
     return (stg_arg : stg_args, fvs, ticks ++ aticks)
632 633


634 635 636 637 638
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
639 640 641 642 643 644 645 646
         :: 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
647

twanvl's avatar
twanvl committed
648
coreToStgLet let_no_escape bind body = do
649 650 651 652 653 654
    (bind2, bind_fvs, bind_escs,
     body2, body_fvs, body_escs)
       <- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do

          ( bind2, bind_fvs, bind_escs, env_ext)
                <- vars_bind rec_body_fvs bind
655

twanvl's avatar
twanvl committed
656 657 658
          -- Do the body
          extendVarEnvLne env_ext $ do
             (body2, body_fvs, body_escs) <- coreToStgExpr body
659

660 661
             return (bind2, bind_fvs, bind_escs,
                     body2, body_fvs, body_escs)
662 663


664
        -- Compute the new let-expression
665
    let
666
        new_let | let_no_escape = StgLetNoEscape bind2 body2
667
                | otherwise     = StgLet bind2 body2
668

669 670
        free_in_whole_let
          = binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
671

672 673 674 675 676
        real_bind_escs = if let_no_escape then
                            bind_escs
                         else
                            getFVSet bind_fvs
                            -- Everything escapes which is free in the bindings
677

678
        let_escs = (real_bind_escs `unionVarSet` body_escs) `delVarSetList` binders
679

680 681
        all_escs = bind_escs `unionVarSet` body_escs    -- Still includes binders of
                                                        -- this let(rec)
682

683
        no_binder_escapes = isEmptyVarSet (set_of_binders `intersectVarSet` all_escs)
684

685 686 687 688 689 690 691 692 693
        -- 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
694
    return (
695 696 697 698
        new_let,
        free_in_whole_let,
        let_escs,
        checked_no_binder_escapes
twanvl's avatar
twanvl committed
699
      )
700
  where
701
    set_of_binders = mkVarSet binders
702
    binders        = bindersOf bind
703

704 705
    mk_binding binder rhs
        = (binder, LetBound NestedLet (manifestArity rhs))
706 707 708 709 710 711 712 713

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

714

twanvl's avatar
twanvl committed
715
    vars_bind body_fvs (NonRec binder rhs) = do
716
        (rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
717
        let
718
            env_ext_item = mk_binding binder rhs
twanvl's avatar
twanvl committed
719

720
        return (StgNonRec binder rhs2,
721
                bind_fvs, escs, [env_ext_item])
722 723 724


    vars_bind body_fvs (Rec pairs)
725
      = mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
726 727 728
           let
                rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
                binders = map fst pairs
729
                env_ext = [ mk_binding b rhs
730 731 732
                          | (b,rhs) <- pairs ]
           in
           extendVarEnvLne env_ext $ do
733 734
              (rhss2, fvss, escss)
                     <- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs
735 736 737 738 739
              let
                        bind_fvs = unionFVInfos fvss
                        escs     = unionVarSets escss

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

742 743 744 745

is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
-- a variable started life as a join point ($j)
746
is_join_var j = occNameString (getOccName j) == "$j"
747

Jan Stolarek's avatar
Jan Stolarek committed
748
coreToStgRhs :: FreeVarsInfo      -- Free var info for the scope of the binding
749
             -> (Id,CoreExpr)
750
             -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
751

752
coreToStgRhs scope_fv_info (bndr, rhs) = do
twanvl's avatar
twanvl committed
753
    (new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
754 755
    return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
            rhs_fvs, rhs_escs)
756 757 758
  where
    bndr_info = lookupFVInfo scope_fv_info bndr

759
mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
760 761
mkStgRhs = mkStgRhs' con_updateable
  where con_updateable _ _ = False
762

763
mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
764 765
            -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
766
  | StgLam bndrs body <- rhs
767
  = StgRhsClosure noCCS binder_info
768 769
                   (getFVs rhs_fvs)
                   ReEntrant
770
                   bndrs body
771 772 773 774
  | StgConApp con args <- unticked_rhs
  , not (con_updateable con args)
  = StgRhsCon noCCS con args
  | otherwise
775
  = StgRhsClosure noCCS binder_info
776
                   (getFVs rhs_fvs)
777
                   upd_flag [] rhs
778 779 780 781
 where

    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs

782 783
    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable
784

785 786 787 788 789
  {-
    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).

790
    upd_flag | isPAP env rhs  = ReEntrant
791
             | otherwise      = Updatable
Jan Stolarek's avatar
Jan Stolarek committed
792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817

-- 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,
--
--         - the thunk is more efficient to enter, because it is
--           specialised to the task.
--
--         - we save one update frame, one stg_update_PAP, one update
--           and lots of PAP_enters.
--
--         - 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.
--
-- 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
                              where
                                 arity = stgArity f (lookupBinding env f)
isPAP env _               = False

-}
818

819 820
{- ToDo:
          upd = if isOnceDem dem
821 822 823
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
824
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
825
                     Updatable)
826
                else Updatable
827 828 829 830
        -- 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
831
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
832 833 834 835
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

Jan Stolarek's avatar
Jan Stolarek committed
836 837 838
-- ---------------------------------------------------------------------------
-- A little monad for this let-no-escaping pass
-- ---------------------------------------------------------------------------
839

Jan Stolarek's avatar
Jan Stolarek committed
840 841
-- There's a lot of stuff to pass around, so we use this LneM monad to
-- help.  All the stuff here is only passed *down*.
842

twanvl's avatar
twanvl committed
843 844 845 846
newtype LneM a = LneM
    { unLneM :: IdEnv HowBound
             -> a
    }
847

848 849
type EscVarsSet = IdSet

850
data HowBound
851 852
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
853

854 855 856
  | 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)
857

858
  | LambdaBound         -- Used for both lambda and case
859
  deriving (Eq)
860

861
data LetInfo
862
  = TopLet              -- top level things
863
  | NestedLet
864
  deriving (Eq)
865

Ian Lynagh's avatar
Ian Lynagh committed
866
isLetBound :: HowBound -> Bool
867
isLetBound (LetBound _ _) = True
Ian Lynagh's avatar
Ian Lynagh committed
868
isLetBound _              = False
869

Ian Lynagh's avatar
Ian Lynagh committed
870 871
topLevelBound :: HowBound -> Bool
topLevelBound ImportBound         = True
872
topLevelBound (LetBound TopLet _) = True
Ian Lynagh's avatar
Ian Lynagh committed
873
topLevelBound _                   = False
874

Jan Stolarek's avatar
Jan Stolarek committed
875 876 877 878 879 880 881 882 883 884 885 886 887
-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
-- variables that are live if x is live.  This LiveInfo comprises
--         (a) dynamic live variables (ones with a non-top-level binding)
--         (b) static live variabes (CAFs or things that refer to CAFs)
--
-- 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 variables in it.
888

Jan Stolarek's avatar
Jan Stolarek committed
889
-- The std monad functions:
890

891
initLne :: IdEnv HowBound -> LneM a -> a
892
initLne env m = unLneM m env