CoreToStg.hs 33.6 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 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 StgSyn
25

26
import Type
27
import 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, nameOccName, nameModule_maybe )
lukemaurer's avatar
lukemaurer committed
37
import OccName          ( occNameFS )
38
import BasicTypes       ( Arity )
39
import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
40
import Literal
41
import Outputable
twanvl's avatar
twanvl committed
42
import MonadUtils
43
import FastString
Ian Lynagh's avatar
Ian Lynagh committed
44
import Util
Ian Lynagh's avatar
Ian Lynagh committed
45
import DynFlags
46
import ForeignCall
47
import Demand           ( isUsedOnce )
48
import PrimOp           ( PrimCall(..), primOpWrapperId )
49
import SrcLoc           ( mkGeneralSrcSpan )
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.

Ben Gamari's avatar
Ben Gamari committed
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.
Ben Gamari's avatar
Ben Gamari committed
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 env $
267
              coreToTopStgRhs dflags ccs this_mod (id,rhs)
268

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

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

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

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

297
        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
298
    in
299
    assertConsistentCaInfo dflags (head binders) bind (ppr binders)
300
    (env', ccs', bind)
301

302 303 304 305 306 307 308 309 310
-- | CAF consistency issues will generally result in segfaults and are quite
-- difficult to debug (see #16846). We enable checking of the
-- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that
-- we catch these issues.
assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a
assertConsistentCaInfo dflags id bind err_doc result
  | gopt Opt_DoStgLinting dflags || debugIsOn
  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc
  | otherwise = result
311

312 313 314 315
-- 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.
316
consistentCafInfo :: Id -> StgTopBinding -> Bool
317
consistentCafInfo id bind
318
  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
319
    safe
320
  where
321 322 323
    safe  = id_marked_caffy || not binding_is_caffy
    exact = id_marked_caffy == binding_is_caffy
    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
324
    binding_is_caffy = topStgBindHasCafRefs bind
325
    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
326

327
coreToTopStgRhs
Ian Lynagh's avatar
Ian Lynagh committed
328
        :: DynFlags
329
        -> CollectedCCs
330
        -> Module
331
        -> (Id,CoreExpr)
332
        -> CtsM (StgRhs, CollectedCCs)
333

334
coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
335
  = do { new_rhs <- coreToStgExpr rhs
336

337
       ; let (stg_rhs, ccs') =
338
               mkTopStgRhs dflags this_mod ccs bndr new_rhs
339 340 341
             stg_arity =
               stgRhsArity stg_rhs

342
       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
343
                 ccs') }
344
  where
345 346 347
        -- 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
348
        --      (#2844 was an example where this happened)
349 350 351 352 353 354
        -- 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
355 356
    arity_ok stg_arity
       | isExternalName (idName bndr) = id_arity == stg_arity
357
       | otherwise                    = True
358 359
    id_arity  = idArity bndr
    mk_arity_msg stg_arity
360
        = vcat [ppr bndr,
361 362
                text "Id arity:" <+> ppr id_arity,
                text "STG arity:" <+> ppr stg_arity]
363

364 365 366
-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
367

368
coreToStgExpr
369
        :: CoreExpr
370
        -> CtsM StgExpr
371

Jan Stolarek's avatar
Jan Stolarek committed
372 373 374 375 376
-- 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.
377

378 379 380 381
-- 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"
382
coreToStgExpr (Lit l)      = return (StgLit l)
Sylvain Henry's avatar
Sylvain Henry committed
383 384
coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
385 386
  -- a STG to Cmm pass.
  = coreToStgExpr (Var unitDataConId)
387 388
coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
sof's avatar
sof committed
389

390
coreToStgExpr expr@(App _ _)
391
  = coreToStgApp Nothing f args ticks
392
  where
393
    (f, args, ticks) = myCollectArgs expr
394

395
coreToStgExpr expr@(Lam _ _)
396
  = let
397 398
        (args, body) = myCollectBinders expr
        args'        = filterStgBinders args
399
    in
lukemaurer's avatar
lukemaurer committed
400
    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
401
    body' <- coreToStgExpr body
402
    let
403
        result_expr = case nonEmpty args' of
404 405
          Nothing     -> body'
          Just args'' -> StgLam args'' body'
406

407
    return result_expr
twanvl's avatar
twanvl committed
408

409 410 411 412 413 414
coreToStgExpr (Tick tick expr)
  = do case tick of
         HpcTick{}    -> return ()
         ProfNote{}   -> return ()
         SourceNote{} -> return ()
         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
415 416
       expr2 <- coreToStgExpr expr
       return (StgTick tick expr2)
Peter Wortmann's avatar
Peter Wortmann committed
417

Ian Lynagh's avatar
Ian Lynagh committed
418
coreToStgExpr (Cast expr _)
419 420
  = coreToStgExpr expr

421 422
-- Cases require a little more real work.

423 424
coreToStgExpr (Case scrut _ _ [])
  = coreToStgExpr scrut
425 426 427 428 429 430 431 432
    -- 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.
433

434

twanvl's avatar
twanvl committed
435
coreToStgExpr (Case scrut bndr _ alts) = do
436 437 438
    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
    scrut2 <- coreToStgExpr scrut
    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
439
  where
440
    vars_alt (con, binders, rhs)
441
      | DataAlt c <- con, c == unboxedUnitDataCon
442
      = -- This case is a bit smelly.
443
        -- See Note [Nullary unboxed tuple] in Type.hs
444 445
        -- where a nullary tuple is mapped to (State# World#)
        ASSERT( null binders )
446 447
        do { rhs2 <- coreToStgExpr rhs
           ; return (DEFAULT, [], rhs2)  }
448
      | otherwise
449 450 451
      = let     -- Remove type variables
            binders' = filterStgBinders binders
        in
lukemaurer's avatar
lukemaurer committed
452
        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
453 454
        rhs2 <- coreToStgExpr rhs
        return (con, binders', rhs2)
455

twanvl's avatar
twanvl committed
456
coreToStgExpr (Let bind body) = do
lukemaurer's avatar
lukemaurer committed
457
    coreToStgLet bind body
Ian Lynagh's avatar
Ian Lynagh committed
458 459

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

Ian Lynagh's avatar
Ian Lynagh committed
461
mkStgAltType :: Id -> [CoreAlt] -> AltType
Richard Eisenberg's avatar
Richard Eisenberg committed
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476
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)
477
  where
Richard Eisenberg's avatar
Richard Eisenberg committed
478 479 480
   bndr_ty   = idType bndr
   prim_reps = typePrimRep bndr_ty

481
   _is_poly_alt_tycon tc
482
        =  isFunTyCon tc
483
        || isPrimTyCon tc   -- "Any" is lifted but primitive
484
        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
485 486
                            -- function application where argument has a
                            -- type-family type
487

488 489
   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
   -- constructors inside it.  Then we may get a better TyCon by
490
   -- grabbing the one from a constructor alternative
491 492
   -- if one exists.
   look_for_better_tycon
493 494 495 496 497 498 499
        | ((DataAlt con, _, _) : _) <- data_alts =
                AlgAlt (dataConTyCon con)
        | otherwise =
                ASSERT(null data_alts)
                PolyAlt
        where
                (data_alts, _deflt) = findDefault alts
500

501 502 503 504
-- ---------------------------------------------------------------------------
-- Applications
-- ---------------------------------------------------------------------------

505
coreToStgApp
506 507 508 509 510 511
         :: 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
512
        -> [Tickish Id]                 -- Debug ticks
513
        -> CtsM StgExpr
514

515

516
coreToStgApp _ f args ticks = do
517
    (args', ticks') <- coreToStgArgs args
lukemaurer's avatar
lukemaurer committed
518
    how_bound <- lookupVarCts f
519 520

    let
521
        n_val_args       = valArgCount args
522

523 524 525 526 527 528 529 530 531 532 533 534
        -- 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
535 536 537
                DataConWorkId dc
                  | saturated    -> StgConApp dc args'
                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
538 539

                -- Some primitive operator that might be implemented as a library call.
540 541 542 543 544 545
                -- 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'
546 547

                -- A call to some primitive Cmm function.
548 549
                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
                                          PrimCallConv _))
550 551 552 553 554
                                 -> ASSERT( saturated )
                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty

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

557
                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
558
                _other           -> StgApp f args'
559

560 561
        tapp = foldr StgTick app (ticks ++ ticks')

562 563
    -- Forcing these fixes a leak in the code generator, noticed while
    -- profiling for trac #4367
564
    app `seq` return tapp
565

566 567 568 569 570
-- ---------------------------------------------------------------------------
-- Argument lists
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------

571
coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
572
coreToStgArgs []
573
  = return ([], [])
574

Ian Lynagh's avatar
Ian Lynagh committed
575
coreToStgArgs (Type _ : args) = do     -- Type argument
576 577
    (args', ts) <- coreToStgArgs args
    return (args', ts)
578

579
coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
580 581
  = do { (args', ts) <- coreToStgArgs args
       ; return (StgVarArg coercionTokenId : args', ts) }
582 583 584

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

twanvl's avatar
twanvl committed
588
coreToStgArgs (arg : args) = do         -- Non-type argument
589 590
    (stg_args, ticks) <- coreToStgArgs args
    arg' <- coreToStgExpr arg
591
    let
592 593
        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
        stg_arg = case arg'' of
594 595 596 597
                       StgApp v []        -> StgVarArg v
                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
                       StgLit lit         -> StgLitArg lit
                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
598 599 600 601 602 603 604 605 606 607

        -- 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
608
    let
609 610
        arg_ty = exprType arg
        stg_arg_ty = stgArgType stg_arg
611
        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
Richard Eisenberg's avatar
Richard Eisenberg committed
612
                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
613 614 615 616 617
        -- 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
618

619
    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
620
     return (stg_arg : stg_args, ticks ++ aticks)
621 622


623 624 625 626 627
-- ---------------------------------------------------------------------------
-- The magic for lets:
-- ---------------------------------------------------------------------------

coreToStgLet
628 629 630
         :: CoreBind     -- bindings
         -> CoreExpr     -- body
         -> CtsM StgExpr -- new let
lukemaurer's avatar
lukemaurer committed
631 632

coreToStgLet bind body = do
633
    (bind2, body2)
634
       <- do
lukemaurer's avatar
lukemaurer committed
635

636
          ( bind2, env_ext)
637
                <- vars_bind bind
638

twanvl's avatar
twanvl committed
639
          -- Do the body
lukemaurer's avatar
lukemaurer committed
640
          extendVarEnvCts env_ext $ do
641
             body2 <- coreToStgExpr body
642

643
             return (bind2, body2)
644

645
        -- Compute the new let-expression
646
    let
Sebastian Graf's avatar
Sebastian Graf committed
647 648
        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2
                | otherwise       = StgLet noExtSilent bind2 body2
649

650
    return new_let
651
  where
652 653
    mk_binding binder rhs
        = (binder, LetBound NestedLet (manifestArity rhs))
654

655
    vars_bind :: CoreBind
lukemaurer's avatar
lukemaurer committed
656
              -> CtsM (StgBinding,
657 658
                       [(Id, HowBound)])  -- extension to environment

659
    vars_bind (NonRec binder rhs) = do
660
        rhs2 <- coreToStgRhs (binder,rhs)
661
        let
662
            env_ext_item = mk_binding binder rhs
twanvl's avatar
twanvl committed
663

664
        return (StgNonRec binder rhs2, [env_ext_item])
665

666 667
    vars_bind (Rec pairs)
      =    let
668
                binders = map fst pairs
669
                env_ext = [ mk_binding b rhs
670 671
                          | (b,rhs) <- pairs ]
           in
lukemaurer's avatar
lukemaurer committed
672
           extendVarEnvCts env_ext $ do
673 674
              rhss2 <- mapM coreToStgRhs pairs
              return (StgRec (binders `zip` rhss2), env_ext)
675

676
coreToStgRhs :: (Id,CoreExpr)
677
             -> CtsM StgRhs
678

679
coreToStgRhs (bndr, rhs) = do
680 681
    new_rhs <- coreToStgExpr rhs
    return (mkStgRhs bndr new_rhs)
682

683 684 685
-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
-- appended to `CollectedCCs` argument.
mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
686
            -> Id -> StgExpr -> (StgRhs, CollectedCCs)
687

688
mkTopStgRhs dflags this_mod ccs bndr rhs
689
  | StgLam bndrs body <- rhs
690
  = -- StgLam can't have empty arguments, so not CAF
691 692
    ( StgRhsClosure noExtSilent
                    dontCareCCS
693
                    ReEntrant
694
                    (toList bndrs) body
695 696
    , ccs )

697
  | StgConApp con args _ <- unticked_rhs
698 699
  , -- Dynamic StgConApps are updatable
    not (isDllConApp dflags this_mod con args)
700
  = -- CorePrep does this right, but just to make sure
Richard Eisenberg's avatar
Richard Eisenberg committed
701 702
    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
           , ppr bndr $$ ppr con $$ ppr args)
703 704 705 706
    ( StgRhsCon dontCareCCS con args, ccs )

  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
  | gopt Opt_AutoSccsOnIndividualCafs dflags
707 708
  = ( StgRhsClosure noExtSilent
                    caf_ccs
709 710 711
                    upd_flag [] rhs
    , collectCC caf_cc caf_ccs ccs )

712
  | otherwise
713 714
  = ( StgRhsClosure noExtSilent
                    all_cafs_ccs
715 716
                    upd_flag [] rhs
    , ccs )
717

718 719 720 721 722 723 724
  where
    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs

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

    -- CAF cost centres generated for -fcaf-all
725
    caf_cc = mkAutoCC bndr modl
726 727 728 729 730 731 732 733 734 735 736 737
    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,
-- see Note [Cost-centre initialzation plan].
738 739
mkStgRhs :: Id -> StgExpr -> StgRhs
mkStgRhs bndr rhs
740
  | StgLam bndrs body <- rhs
741 742
  = StgRhsClosure noExtSilent
                  currentCCS
743
                  ReEntrant
744
                  (toList bndrs) body
745 746 747

  | isJoinId bndr -- must be a nullary join point
  = ASSERT(idJoinArity bndr == 0)
748 749
    StgRhsClosure noExtSilent
                  currentCCS
750 751 752 753 754 755 756
                  ReEntrant -- ignored for LNE
                  [] rhs

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

  | otherwise
757 758
  = StgRhsClosure noExtSilent
                  currentCCS
759 760
                  upd_flag [] rhs
  where
761 762
    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs

763 764
    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
             | otherwise                      = Updatable
765

766 767 768 769 770
  {-
    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).

771
    upd_flag | isPAP env rhs  = ReEntrant
772
             | otherwise      = Updatable
Jan Stolarek's avatar
Jan Stolarek committed
773 774 775 776 777 778 779 780 781 782 783 784 785

-- 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
Gabor Greif's avatar
Gabor Greif committed
786
--           a black hole and furthermore the thunk isn't considered to
Jan Stolarek's avatar
Jan Stolarek committed
787 788 789 790 791 792 793 794 795 796 797 798
--           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

-}
799

800 801
{- ToDo:
          upd = if isOnceDem dem
802 803 804
                    then (if isNotTop toplev
                            then SingleEntry    -- HA!  Paydirt for "dem"
                            else
Ian Lynagh's avatar
Ian Lynagh committed
805
                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
806
                     Updatable)
807
                else Updatable
808 809 810 811
        -- 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
812
        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
813 814 815 816
        -- specifically Main.lvl6 in spectral/cryptarithm2.
        -- So no great loss.  KSW 2000-07.
-}

Jan Stolarek's avatar
Jan Stolarek committed
817
-- ---------------------------------------------------------------------------
lukemaurer's avatar
lukemaurer committed
818
-- A monad for the core-to-STG pass
Jan Stolarek's avatar
Jan Stolarek committed
819
-- ---------------------------------------------------------------------------
820

lukemaurer's avatar
lukemaurer committed
821 822 823
-- 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*.
824

lukemaurer's avatar
lukemaurer committed
825 826
newtype CtsM a = CtsM
    { unCtsM :: IdEnv HowBound
twanvl's avatar
twanvl committed
827 828
             -> a
    }
829
    deriving (Functor)
830 831

data HowBound
832 833
  = ImportBound         -- Used only as a response to lookupBinding; never
                        -- exists in the range of the (IdEnv HowBound)
834

835 836 837
  | 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)
simonpj's avatar