CoreToStg.hs 32.4 KB
Newer Older
1
{-# LANGUAGE CPP, DeriveFunctor #-}
2

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 GHC.CoreToStg ( coreToStg ) where
15

16
#include "HsVersions.h"
17

18 19
import GhcPrelude

20
import CoreSyn
21 22
import CoreUtils        ( exprType, findDefault, isJoinBind
                        , exprIsTickedString_maybe )
23
import CoreArity        ( manifestArity )
24
import GHC.Stg.Syntax
25

26
import Type
27
import GHC.Types.RepType
28
import TyCon
29
import MkId             ( coercionTokenId )
30 31 32
import Id
import IdInfo
import DataCon
33
import CostCentre
34
import VarEnv
35
import Module
36
import Name             ( isExternalName, nameModule_maybe )
37
import BasicTypes       ( Arity )
38
import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
39
import Literal
40
import Outputable
twanvl's avatar
twanvl committed
41
import MonadUtils
42
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
43
import Util
Ian Lynagh's avatar
Ian Lynagh committed
44
import DynFlags
45
import ForeignCall
46
import Demand           ( isUsedOnce )
47
import PrimOp           ( PrimCall(..), primOpWrapperId )
48
import SrcLoc           ( mkGeneralSrcSpan )
49
import PrelNames        ( unsafeEqualityProofName )
50

51
import Data.List.NonEmpty (nonEmpty, toList)
52
import Data.Maybe    (fromMaybe)
53
import Control.Monad (ap)
Austin Seipp's avatar
Austin Seipp committed
54

Jan Stolarek's avatar
Jan Stolarek committed
55 56 57
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
58 59 60 61
-- 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
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 90 91
--
--           - 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.

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
-- Note [What are these SRTs all about?]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Consider the Core program,
--
--     fibs = go 1 1
--       where go a b = let c = a + c
--                      in c : go b c
--     add x = map (\y -> x*y) fibs
--
-- In this case we have a CAF, 'fibs', which is quite large after evaluation and
-- has only one possible user, 'add'. Consequently, we want to ensure that when
-- all references to 'add' die we can garbage collect any bit of 'fibs' that we
-- have evaluated.
--
-- However, how do we know whether there are any references to 'fibs' still
-- around? Afterall, the only reference to it is buried in the code generated
-- for 'add'. The answer is that we record the CAFs referred to by a definition
-- in its info table, namely a part of it known as the Static Reference Table
-- (SRT).
--
-- Since SRTs are so common, we use a special compact encoding for them in: we
-- produce one table containing a list of CAFs in a module and then include a
-- bitmap in each info table describing which entries of this table the closure
-- references.
--
118
-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.
119

Jan Stolarek's avatar
Jan Stolarek committed
120 121 122
-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
lukemaurer's avatar
lukemaurer committed
123 124 125 126
-- NB: Nowadays this is recognized by the occurrence analyser by turning a
-- "non-escaping let" into a join point. The following is then an operational
-- account of join points.
--
Jan Stolarek's avatar
Jan Stolarek committed
127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
-- 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:
lukemaurer's avatar
lukemaurer committed
143
--   1. non-updatable;
Jan Stolarek's avatar
Jan Stolarek committed
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
--   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)...

179 180 181 182
-- Note [Cost-centre initialization plan]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
Gabor Greif's avatar
Gabor Greif committed
183
-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200
-- We now initialize these correctly. The initialization works like this:
--
--   - For non-top level bindings always use `currentCCS`.
--
--   - For top-level bindings, check if the binding is a CAF
--
--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
--                 and use it. Note that these new cost centres need to be
--                 collected to be able to generate cost centre initialization
--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
--
--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
--
--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
--                 do we set CCCS from it; so we just slam in
--                 dontCareCostCentre.

Jan Stolarek's avatar
Jan Stolarek committed
201 202 203
-- --------------------------------------------------------------
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
204

205 206
coreToStg :: DynFlags -> Module -> CoreProgram
          -> ([StgTopBinding], CollectedCCs)
207
coreToStg dflags this_mod pgm
208 209
  = (pgm', final_ccs)
  where
210
    (_, (local_ccs, local_cc_stacks), pgm')
211
      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
212

213 214 215 216 217 218 219 220 221
    prof = WayProf `elem` ways dflags

    final_ccs
      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
      | prof
      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
      | otherwise
      = emptyCollectedCCs
222

223
    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
224 225

coreTopBindsToStg
Ian Lynagh's avatar
Ian Lynagh committed
226
    :: DynFlags
227
    -> Module
228
    -> IdEnv HowBound           -- environment for the bindings
229
    -> CollectedCCs
230
    -> CoreProgram
231
    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
232

233
coreTopBindsToStg _      _        env ccs []
234
  = (env, ccs, [])
235
coreTopBindsToStg dflags this_mod env ccs (b:bs)
236
  = (env2, ccs2, b':bs')
237
  where
238 239 240
        (env1, ccs1, b' ) =
          coreTopBindToStg dflags this_mod env ccs b
        (env2, ccs2, bs') =
241
          coreTopBindsToStg dflags this_mod env1 ccs1 bs
242 243

coreTopBindToStg
Ian Lynagh's avatar
Ian Lynagh committed
244
        :: DynFlags
245
        -> Module
246
        -> IdEnv HowBound
247
        -> CollectedCCs
248
        -> CoreBind
249
        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
250

251
coreTopBindToStg _ _ env ccs (NonRec id e)
252
  | Just str <- exprIsTickedString_maybe e
253
  -- top-level string literal
254
  -- See Note [CoreSyn top-level string literals] in CoreSyn
255 256 257
  = let
        env' = extendVarEnv env id how_bound
        how_bound = LetBound TopLet 0
258
    in (env', ccs, StgTopStringLit id str)
259

260
coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
261 262 263
  = let
        env'      = extendVarEnv env id how_bound
        how_bound = LetBound TopLet $! manifestArity rhs
264

265
        (stg_rhs, ccs') =
266
            initCts dflags env $
267
              coreToTopStgRhs dflags ccs this_mod (id,rhs)
268

269
        bind = StgTopLifted $ StgNonRec id stg_rhs
270
    in
271 272 273 274
      -- 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!
275
    (env', ccs', bind)
276

277
coreTopBindToStg dflags this_mod env ccs (Rec pairs)
278
  = ASSERT( not (null pairs) )
279 280
    let
        binders = map fst pairs
281

282 283 284
        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
                     | (b, rhs) <- pairs ]
        env' = extendVarEnvList env extra_env'
285

286 287
        -- generate StgTopBindings and CAF cost centres created for CAFs
        (ccs', stg_rhss)
288
          = initCts dflags env' $ do
289 290
               mapAccumLM (\ccs rhs -> do
                            (rhs', ccs') <-
291
                              coreToTopStgRhs dflags ccs this_mod rhs
292 293
                            return (ccs', rhs'))
                          ccs
294
                          pairs
295

296
        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
297
    in
298
    (env', ccs', bind)
299

300
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
301
        :: DynFlags
302
        -> CollectedCCs
303
        -> Module
304
        -> (Id,CoreExpr)
305
        -> CtsM (StgRhs, CollectedCCs)
306

307
coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
308
  = do { new_rhs <- coreToStgExpr rhs
309

310
       ; let (stg_rhs, ccs') =
311
               mkTopStgRhs dflags this_mod ccs bndr new_rhs
312 313 314
             stg_arity =
               stgRhsArity stg_rhs

315
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
316
                 ccs') }
317
  where
318 319 320
        -- 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
321
        --      (#2844 was an example where this happened)
322 323 324 325 326 327
        -- 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
328 329
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
330
       | otherwise                    = True
331 332
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
333
        = vcat [ppr bndr,
334 335
                text "Id arity:" <+> ppr id_arity,
                text "STG arity:" <+> ppr stg_arity]
336

337 338 339
-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
340

341
coreToStgExpr
342
        :: CoreExpr
343
        -> CtsM StgExpr
344

Jan Stolarek's avatar
Jan Stolarek committed
345 346 347 348 349
-- 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.
350

351 352 353 354
-- No LitInteger's or LitNatural's should be left by the time this is called.
-- CorePrep should have converted them all to a real core representation.
coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
355
coreToStgExpr (Lit l)      = return (StgLit l)
Sylvain Henry's avatar
Sylvain Henry committed
356 357
coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
358 359
  -- a STG to Cmm pass.
  = coreToStgExpr (Var unitDataConId)
360 361
coreToStgExpr (Var v)      = coreToStgApp v               [] []
coreToStgExpr (Coercion _) = coreToStgApp coercionTokenId [] []
sof's avatar
sof committed
362

363
coreToStgExpr expr@(App _ _)
364
  = coreToStgApp f args ticks
365
  where
366
    (f, args, ticks) = myCollectArgs expr
367

368
coreToStgExpr expr@(Lam _ _)
369
  = let
370 371
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
372
    in
lukemaurer's avatar
lukemaurer committed
373
    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
374
    body' <- coreToStgExpr body
375
    let
376
        result_expr = case nonEmpty args' of
377 378
          Nothing     -> body'
          Just args'' -> StgLam args'' body'
379

380
    return result_expr
twanvl's avatar
twanvl committed
381

382 383 384 385 386 387
coreToStgExpr (Tick tick expr)
  = do case tick of
         HpcTick{}    -> return ()
         ProfNote{}   -> return ()
         SourceNote{} -> return ()
         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
388 389
       expr2 <- coreToStgExpr expr
       return (StgTick tick expr2)
Peter Wortmann's avatar
Peter Wortmann committed
390

Ian Lynagh's avatar
Ian Lynagh committed
391
coreToStgExpr (Cast expr _)
392 393
  = coreToStgExpr expr

394 395
-- Cases require a little more real work.

396 397
coreToStgExpr (Case scrut _ _ [])
  = coreToStgExpr scrut
398 399 400 401 402 403 404 405
    -- 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.
406

407

408
coreToStgExpr e0@(Case scrut bndr _ alts) = do
409 410
    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
    scrut2 <- coreToStgExpr scrut
411 412 413 414 415 416 417 418 419 420 421 422
    let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2
    -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
    case scrut2 of
      StgApp id [] | idName id == unsafeEqualityProofName ->
        case alts2 of
          [(_, [_co], rhs)] ->
            return rhs
          _ ->
            pprPanic "coreToStgExpr" $
              text "Unexpected unsafe equality case expression:" $$ ppr e0 $$
              text "STG:" $$ ppr stg
      _ -> return stg
423
  where
424
    vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
425
    vars_alt (con, binders, rhs)
426
      | DataAlt c <- con, c == unboxedUnitDataCon
427
      = -- This case is a bit smelly.
428
        -- See Note [Nullary unboxed tuple] in Type.hs
429 430
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
431 432
        do { rhs2 <- coreToStgExpr rhs
           ; return (DEFAULT, [], rhs2)  }
433
      | otherwise
434 435 436
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
lukemaurer's avatar
lukemaurer committed
437
        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
438 439
        rhs2 <- coreToStgExpr rhs
        return (con, binders', rhs2)
440

twanvl's avatar
twanvl committed
441
coreToStgExpr (Let bind body) = do
lukemaurer's avatar
lukemaurer committed
442
    coreToStgLet bind body
Ian Lynagh's avatar
Ian Lynagh committed
443 444

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

Ian Lynagh's avatar
Ian Lynagh committed
446
mkStgAltType :: Id -> [CoreAlt] -> AltType
447 448 449 450 451 452 453 454 455 456 457 458 459 460 461
mkStgAltType bndr alts
  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples

  | otherwise
  = case prim_reps of
      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
        Just tc
          | isAbstractTyCon tc -> look_for_better_tycon
          | isAlgTyCon tc      -> AlgAlt tc
          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
                                  PolyAlt
        Nothing                -> PolyAlt
      [unlifted] -> PrimAlt unlifted
      not_unary  -> MultiValAlt (length not_unary)
462
  where
463 464 465
   bndr_ty   = idType bndr
   prim_reps = typePrimRep bndr_ty

466
   _is_poly_alt_tycon tc
467
        =  isFunTyCon tc
468
        || isPrimTyCon tc   -- "Any" is lifted but primitive
469
        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
470 471
                            -- function application where argument has a
                            -- type-family type
472

473 474
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
475
   -- grabbing the one from a constructor alternative
476 477
   -- if one exists.
   look_for_better_tycon
478 479 480 481 482 483 484
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
485

486 487 488 489
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

490 491 492 493 494
coreToStgApp :: Id            -- Function
             -> [CoreArg]     -- Arguments
             -> [Tickish Id]  -- Debug ticks
             -> CtsM StgExpr
coreToStgApp f args ticks = do
495
    (args', ticks') <- coreToStgArgs args
lukemaurer's avatar
lukemaurer committed
496
    how_bound <- lookupVarCts f
497 498

    let
499
        n_val_args       = valArgCount args
500

501 502 503 504 505 506 507 508 509 510 511 512
        -- 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

        res_ty = exprType (mkApps (Var f) args)
        app = case idDetails f of
513 514 515
                DataConWorkId dc
                  | saturated    -> StgConApp dc args'
                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
516 517

                -- Some primitive operator that might be implemented as a library call.
518 519 520 521 522 523
                -- As described in Note [Primop wrappers] in PrimOp.hs, here we
                -- turn unsaturated primop applications into applications of
                -- the primop's wrapper.
                PrimOpId op
                  | saturated    -> StgOpApp (StgPrimOp op) args' res_ty
                  | otherwise    -> StgApp (primOpWrapperId op) args'
524 525

                -- A call to some primitive Cmm function.
526 527
                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
                                          PrimCallConv _))
528 529 530 531 532
                                 -> ASSERT( saturated )
                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty

                -- A regular foreign call.
                FCallId call     -> ASSERT( saturated )
533
                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty
534

535
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
536
                _other           -> StgApp f args'
537

538 539
        tapp = foldr StgTick app (ticks ++ ticks')

540 541
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
542
    app `seq` return tapp
543

544 545 546 547 548
-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

549
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
550
coreToStgArgs []
551
  = return ([], [])
552

Ian Lynagh's avatar
Ian Lynagh committed
553
coreToStgArgs (Type _ : args) = do     -- Type argument
554 555
    (args', ts) <- coreToStgArgs args
    return (args', ts)
556

557
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
558 559
  = do { (args', ts) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', ts) }
560 561 562

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

twanvl's avatar
twanvl committed
566
coreToStgArgs (arg : args) = do         -- Non-type argument
567 568
    (stg_args, ticks) <- coreToStgArgs args
    arg' <- coreToStgExpr arg
569
    let
570 571
        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
        stg_arg = case arg'' of
572 573 574 575
                       StgApp v []        -> StgVarArg v
                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
                       StgLit lit         -> StgLitArg lit
                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
576 577 578 579 580 581 582 583 584 585

        -- 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
586 587

    dflags <- getDynFlags
588
    let
589 590 591
        arg_rep = typePrimRep (exprType arg)
        stg_arg_rep = typePrimRep (stgArgType stg_arg)
        bad_args = not (primRepsCompatible dflags arg_rep stg_arg_rep)
twanvl's avatar
twanvl committed
592

593
    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
594
     return (stg_arg : stg_args, ticks ++ aticks)
595 596


597 598 599 600 601
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
602 603 604
         :: CoreBind     -- bindings
         -> CoreExpr     -- body
         -> CtsM StgExpr -- new let
lukemaurer's avatar
lukemaurer committed
605 606

coreToStgLet bind body = do
607
    (bind2, body2)
608
       <- do
lukemaurer's avatar
lukemaurer committed
609

610
          ( bind2, env_ext)
611
                <- vars_bind bind
612

twanvl's avatar
twanvl committed
613
          -- Do the body
lukemaurer's avatar
lukemaurer committed
614
          extendVarEnvCts env_ext $ do
615
             body2 <- coreToStgExpr body
616

617
             return (bind2, body2)
618

619
        -- Compute the new let-expression
620
    let
621 622
        new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2
                | otherwise       = StgLet noExtFieldSilent bind2 body2
623

624
    return new_let
625
  where
626 627
    mk_binding binder rhs
        = (binder, LetBound NestedLet (manifestArity rhs))
628

629
    vars_bind :: CoreBind
lukemaurer's avatar
lukemaurer committed
630
              -> CtsM (StgBinding,
631 632
                       [(Id, HowBound)])  -- extension to environment

633
    vars_bind (NonRec binder rhs) = do
634
        rhs2 <- coreToStgRhs (binder,rhs)
635
        let
636
            env_ext_item = mk_binding binder rhs
twanvl's avatar
twanvl committed
637

638
        return (StgNonRec binder rhs2, [env_ext_item])
639

640 641
    vars_bind (Rec pairs)
      =    let
642
                binders = map fst pairs
643
                env_ext = [ mk_binding b rhs
644 645
                          | (b,rhs) <- pairs ]
           in
lukemaurer's avatar
lukemaurer committed
646
           extendVarEnvCts env_ext $ do
647 648
              rhss2 <- mapM coreToStgRhs pairs
              return (StgRec (binders `zip` rhss2), env_ext)
649

650
coreToStgRhs :: (Id,CoreExpr)
651
             -> CtsM StgRhs
652

653
coreToStgRhs (bndr, rhs) = do
654 655
    new_rhs <- coreToStgExpr rhs
    return (mkStgRhs bndr new_rhs)
656

657 658 659
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
660
            -> Id -> StgExpr -> (StgRhs, CollectedCCs)
661

662
mkTopStgRhs dflags this_mod ccs bndr rhs
663
  | StgLam bndrs body <- rhs
664
  = -- StgLam can't have empty arguments, so not CAF
665
    ( StgRhsClosure noExtFieldSilent
666
                    dontCareCCS
667
                    ReEntrant
668
                    (toList bndrs) body
669 670
    , ccs )

671
  | StgConApp con args _ <- unticked_rhs
672 673
  , -- Dynamic StgConApps are updatable
    not (isDllConApp dflags this_mod con args)
674
  = -- CorePrep does this right, but just to make sure
675 676
    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
           , ppr bndr $$ ppr con $$ ppr args)
677 678 679 680
    ( StgRhsCon dontCareCCS con args, ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | gopt Opt_AutoSccsOnIndividualCafs dflags
681
  = ( StgRhsClosure noExtFieldSilent
682
                    caf_ccs
683 684 685
                    upd_flag [] rhs
    , collectCC caf_cc caf_ccs ccs )

686
  | otherwise
687
  = ( StgRhsClosure noExtFieldSilent
688
                    all_cafs_ccs
689 690
                    upd_flag [] rhs
    , ccs )
691

692
  where
693
    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
694 695 696 697 698

    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable

    -- CAF cost centres generated for -fcaf-all
699
    caf_cc = mkAutoCC bndr modl
700 701 702 703 704 705 706 707 708 709 710
    caf_ccs = mkSingletonCCS caf_cc
           -- careful: the binder might be :Main.main,
           -- which doesn't belong to module mod_name.
           -- bug #249, tests prof001, prof002
    modl | Just m <- nameModule_maybe (idName bndr) = m
         | otherwise = this_mod

    -- default CAF cost centre
    (_, all_cafs_ccs) = getAllCAFsCC this_mod

-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
711
-- see Note [Cost-centre initialization plan].
712 713
mkStgRhs :: Id -> StgExpr -> StgRhs
mkStgRhs bndr rhs
714
  | StgLam bndrs body <- rhs
715
  = StgRhsClosure noExtFieldSilent
716
                  currentCCS
717
                  ReEntrant
718
                  (toList bndrs) body
719 720 721

  | isJoinId bndr -- must be a nullary join point
  = ASSERT(idJoinArity bndr == 0)
722
    StgRhsClosure noExtFieldSilent
723
                  currentCCS
724 725 726 727 728 729 730
                  ReEntrant -- ignored for LNE
                  [] rhs

  | StgConApp con args _ <- unticked_rhs
  = StgRhsCon currentCCS con args

  | otherwise
731
  = StgRhsClosure noExtFieldSilent
732
                  currentCCS
733 734
                  upd_flag [] rhs
  where
735
    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
736

737 738
    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable
739

740 741 742 743 744
  {-
    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).

745
    upd_flag | isPAP env rhs  = ReEntrant
746
             | otherwise      = Updatable
Jan Stolarek's avatar
Jan Stolarek committed
747 748 749 750 751 752 753 754 755 756 757 758 759

-- 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
760
--           a black hole and furthermore the thunk isn't considered to
Jan Stolarek's avatar
Jan Stolarek committed
761 762 763 764 765 766 767 768 769 770 771 772
--           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

-}
773

774 775
{- ToDo:
          upd = if isOnceDem dem
776 777 778
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
779
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
780
                     Updatable)
781
                else Updatable
782 783 784 785
        -- 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
786
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
787 788 789 790
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

Jan Stolarek's avatar
Jan Stolarek committed
791
-- ---------------------------------------------------------------------------
lukemaurer's avatar
lukemaurer committed
792
-- A monad for the core-to-STG pass
Jan Stolarek's avatar
Jan Stolarek committed
793
-- ---------------------------------------------------------------------------
794

lukemaurer's avatar
lukemaurer committed
795 796 797
-- There's a lot of stuff to pass around, so we use this CtsM
-- ("core-to-STG monad") monad to help.  All the stuff here is only passed
-- *down*.
798

lukemaurer's avatar
lukemaurer committed
799
newtype CtsM a = CtsM
800 801
    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs
             -> IdEnv HowBound
twanvl's avatar
twanvl committed
802 803
             -> a
    }
804
    deriving (Functor)
805 806

data HowBound
807 808
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
809

810 811 812
  | 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)
813

814
  | LambdaBound         -- Used for both lambda and case
815
  deriving (Eq)
816

817
data LetInfo
818
  = TopLet              -- top level things
819
  | NestedLet
820
  deriving (Eq)
821

Jan Stolarek's avatar
Jan Stolarek committed
822 823 824
-- 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)
825
--         (b) static live variables (CAFs or things that refer to CAFs)
Jan Stolarek's avatar
Jan Stolarek committed
826 827 828 829 830 831 832 833 834
--
-- 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.
835

Jan Stolarek's avatar
Jan Stolarek committed
836
-- The std monad functions:
837

838 839
initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a
initCts dflags env m = unCtsM m dflags env
840

841

842

lukemaurer's avatar
lukemaurer committed
843 844
{-# INLINE thenCts #-}
{-# INLINE returnCts #-}
845

lukemaurer's avatar
lukemaurer committed
846
returnCts :: a -> CtsM a
847
returnCts e = CtsM $ \_ _ -> e
848

lukemaurer's avatar
lukemaurer committed
849
thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
850 851
thenCts m k = CtsM $ \dflags env
  -> unCtsM (k (unCtsM m dflags env)) dflags env
twanvl's avatar
twanvl committed
852

lukemaurer's avatar
lukemaurer committed
853 854
instance Applicative CtsM where
    pure = returnCts
Austin Seipp's avatar
Austin Seipp committed
855 856
    (<*>) = ap

lukemaurer's avatar
lukemaurer committed
857 858
instance Monad CtsM where
    (>>=)  = thenCts
twanvl's avatar
twanvl committed
859

860 861 862
instance HasDynFlags CtsM where
    getDynFlags = CtsM $ \dflags _ -> dflags

Jan Stolarek's avatar
Jan Stolarek committed
863
-- Functions specific to this monad:
864

lukemaurer's avatar
lukemaurer committed
865 866
extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
extendVarEnvCts ids_w_howbound expr
867 868
   =    CtsM $   \dflags env
   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)
869

lukemaurer's avatar
lukemaurer committed
870
lookupVarCts :: Id -> CtsM HowBound
871
lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
872

873 874
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
875 876
                        Just xx -> xx
                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
877

878 879 880 881 882 883 884 885
getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
getAllCAFsCC this_mod =
    let
      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
      all_cafs_cc  = mkAllCafsCC this_mod span
      all_cafs_ccs = mkSingletonCCS all_cafs_cc
    in
      (all_cafs_cc, all_cafs_ccs)
886

Jan Stolarek's avatar
Jan Stolarek committed
887 888
-- Misc.

889
filterStgBinders :: [Var] -> [Var]
890
filterStgBinders bndrs = filter isId bndrs
891

Ian Lynagh's avatar
Ian Lynagh committed
892
myCollectBinders :: Expr Var -> ([Var], Expr Var)
893 894 895 896
myCollectBinders expr
  = go [] expr
  where
    go bs (Lam b e)          = go (b:bs) e
Ian Lynagh's avatar
Ian Lynagh committed
897
    go bs (Cast e _)         = go bs e
898
    go bs e                  = (reverse bs, e)
899

900 901
-- | Precondition: argument expression is an 'App', and there is a 'Var' at the
-- head of the 'App' chain.
902
myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
903
myCollectArgs expr
904
  = go expr [] []
905
  where
906 907 908 909 910 911 912 913
    go (Var v)          as ts = (v, as, ts)
    go (App f a)        as ts = go f (a:as) ts
    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
                                go e as (t:ts) -- ticks can appear in type apps
    go (Cast e _)       as ts = go e as ts
    go (Lam b e)        as ts
       | isTyVar b            = go e as ts -- Note [Collect args]
    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
914

Jan Stolarek's avatar
Jan Stolarek committed
915 916 917 918 919
-- Note [Collect args]
-- ~~~~~~~~~~~~~~~~~~~
--
-- This big-lambda case occurred following a rather obscure eta expansion.
-- It all seems a bit yukky to me.
920

921
stgArity :: Id -> HowBound -> Arity
Ian Lynagh's avatar
Ian Lynagh committed
922
stgArity _ (LetBound _ arity) = arity
923
stgArity f ImportBound        = idArity f
Ian Lynagh's avatar
Ian Lynagh committed
924
stgArity _ LambdaBound        = 0