ByteCodeGen.hs 72.6 KB
Newer Older
1
{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
2
{-# LANGUAGE DeriveFunctor #-}
3
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4
{-# OPTIONS_GHC -fprof-auto-top #-}
5 6 7 8 9
--
--  (c) The University of Glasgow 2002-2006
--

-- | ByteCodeGen: Generate bytecode from Core
10
module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
11 12 13

#include "HsVersions.h"

14 15
import GhcPrelude

16
import ByteCodeInstr
17
import ByteCodeAsm
18
import ByteCodeTypes
19

20 21 22 23
import GHCi
import GHCi.FFI
import GHCi.RemoteTypes
import BasicTypes
ian@well-typed.com's avatar
ian@well-typed.com committed
24
import DynFlags
25
import Outputable
ian@well-typed.com's avatar
ian@well-typed.com committed
26
import Platform
27
import Name
28
import MkId
29
import Id
30 31 32
import ForeignCall
import HscTypes
import CoreUtils
33
import CoreSyn
34 35 36 37 38
import PprCore
import Literal
import PrimOp
import CoreFVs
import Type
39
import RepType
40
import Kind            ( isLiftedTypeKind )
41 42
import DataCon
import TyCon
43
import Util
44 45 46 47 48 49
import VarSet
import TysPrim
import ErrUtils
import Unique
import FastString
import Panic
50
import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
Simon Marlow's avatar
Simon Marlow committed
51
import StgCmmLayout
52
import SMRep hiding (WordOff, ByteOff, wordsToBytes)
53
import Bitmap
54
import OrdList
55
import Maybes
56
import VarEnv
57

Ian Lynagh's avatar
Ian Lynagh committed
58
import Data.List
59
import Foreign
Ian Lynagh's avatar
Ian Lynagh committed
60
import Control.Monad
Ian Lynagh's avatar
Ian Lynagh committed
61
import Data.Char
62

63
import UniqSupply
64
import Module
65
import Control.Arrow ( second )
66

67
import Control.Exception
68
import Data.Array
69
import Data.ByteString (ByteString)
70
import Data.Map (Map)
71
import Data.IntMap (IntMap)
72
import qualified Data.Map as Map
73
import qualified Data.IntMap as IntMap
74
import qualified FiniteMap as Map
75
import Data.Ord
76
import GHC.Stack.CCS
77
import Data.Either ( partitionEithers )
78

79
-- -----------------------------------------------------------------------------
80
-- Generating byte code for a complete module
81

82
byteCodeGen :: HscEnv
83
            -> Module
84
            -> CoreProgram
85
            -> [TyCon]
86
            -> Maybe ModBreaks
87
            -> IO CompiledByteCode
88
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
89 90 91
   = withTiming (pure dflags)
                (text "ByteCodeGen"<+>brackets (ppr this_mod))
                (const ()) $ do
92 93
        -- Split top-level binds into strings and others.
        -- See Note [generating code for top-level string literal bindings].
94
        let (strings, flatBinds) = partitionEithers $ do
95
                (bndr, rhs) <- flattenBinds binds
96 97
                return $ case exprIsTickedString_maybe rhs of
                    Just str -> Left (bndr, str)
98 99
                    _ -> Right (bndr, simpleFreeVars rhs)
        stringPtrs <- allocateTopStrings hsc_env strings
100

101
        us <- mkSplitUniqSupply 'y'
102
        (BcM_State{..}, proto_bcos) <-
103
           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
104
             mapM schemeTopBind flatBinds
105

106
        when (notNull ffis)
107 108
             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")

109
        dumpIfSet_dyn dflags Opt_D_dump_BCOs
110
           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
111

112
        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
113 114 115
          (case modBreaks of
             Nothing -> Nothing
             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
116 117 118 119 120 121 122 123 124 125 126

        -- Squash space leaks in the CompiledByteCode.  This is really
        -- important, because when loading a set of modules into GHCi
        -- we don't touch the CompiledByteCode until the end when we
        -- do linking.  Forcing out the thunks here reduces space
        -- usage by more than 50% when loading a large number of
        -- modules.
        evaluate (seqCompiledByteCode cbc)

        return cbc

127
  where dflags = hsc_dflags hsc_env
128

129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
allocateTopStrings
  :: HscEnv
  -> [(Id, ByteString)]
  -> IO [(Var, RemotePtr ())]
allocateTopStrings hsc_env topStrings = do
  let !(bndrs, strings) = unzip topStrings
  ptrs <- iservCmd hsc_env $ MallocStrings strings
  return $ zip bndrs ptrs

{-
Note [generating code for top-level string literal bindings]

Here is a summary on how the byte code generator deals with top-level string
literals:

144
1. Top-level string literal bindings are separated from the rest of the module.
145 146 147 148 149 150 151

2. The strings are allocated via iservCmd, in allocateTopStrings

3. The mapping from binders to allocated strings (topStrings) are maintained in
   BcM and used when generating code for variable references.
-}

152 153
-- -----------------------------------------------------------------------------
-- Generating byte code for an expression
154

155
-- Returns: the root BCO for this expression
156
coreExprToBCOs :: HscEnv
157
               -> Module
158
               -> CoreExpr
159
               -> IO UnlinkedBCO
160
coreExprToBCOs hsc_env this_mod expr
161 162 163
 = withTiming (pure dflags)
              (text "ByteCodeGen"<+>brackets (ppr this_mod))
              (const ()) $ do
164 165
      -- create a totally bogus name for the top-level BCO; this
      -- should be harmless, since it's never used for anything
Ian Lynagh's avatar
Ian Lynagh committed
166
      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
167
          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
168

169 170 171
      -- the uniques are needed to generate fresh variables when we introduce new
      -- let bindings for ticked expressions
      us <- mkSplitUniqSupply 'y'
172 173
      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
         <- runBc hsc_env us this_mod Nothing emptyVarEnv $
174
              schemeTopBind (invented_id, simpleFreeVars expr)
175

sof's avatar
sof committed
176
      when (notNull mallocd)
177 178
           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")

179
      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
180

181
      assembleOneBCO hsc_env proto_bco
182
  where dflags = hsc_dflags hsc_env
183

184
-- The regular freeVars function gives more information than is useful to
Gabor Greif's avatar
Gabor Greif committed
185
-- us here. simpleFreeVars does the impedance matching.
186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208
simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
simpleFreeVars = go . freeVars
  where
    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
    go (ann, e) = (freeVarsOfAnn ann, go' e)

    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
    go' (AnnVar id)                  = AnnVar id
    go' (AnnLit lit)                 = AnnLit lit
    go' (AnnLam bndr body)           = AnnLam bndr (go body)
    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)
    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)
    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)
    go' (AnnTick tick body)          = AnnTick tick (go body)
    go' (AnnType ty)                 = AnnType ty
    go' (AnnCoercion co)             = AnnCoercion co

    go_alt (con, args, expr) = (con, args, go expr)

    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)

209 210
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
211 212 213

type BCInstrList = OrdList BCInstr

214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236
newtype ByteOff = ByteOff Int
    deriving (Enum, Eq, Integral, Num, Ord, Real)

newtype WordOff = WordOff Int
    deriving (Enum, Eq, Integral, Num, Ord, Real)

wordsToBytes :: DynFlags -> WordOff -> ByteOff
wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral

-- Used when we know we have a whole number of words
bytesToWords :: DynFlags -> ByteOff -> WordOff
bytesToWords dflags (ByteOff bytes) =
    let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
    in if r == 0
           then fromIntegral q
           else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes

wordSize :: DynFlags -> ByteOff
wordSize dflags = ByteOff (wORD_SIZE dflags)

type Sequel = ByteOff -- back off to this depth before ENTER

type StackDepth = ByteOff
237

238 239
-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
-- it after each push/pop.
240
type BCEnv = Map Id StackDepth -- To find vars on the stack
241

Ian Lynagh's avatar
Ian Lynagh committed
242
{-
243 244 245
ppBCEnv :: BCEnv -> SDoc
ppBCEnv p
   = text "begin-env"
246
     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
247 248
     $$ text "end-env"
     where
Simon Marlow's avatar
Simon Marlow committed
249
        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
250
        cmp_snd x y = compare (snd x) (snd y)
Ian Lynagh's avatar
Ian Lynagh committed
251
-}
252

253 254
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
255
mkProtoBCO
256 257
   :: DynFlags
   -> name
258
   -> BCInstrList
259
   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
260
   -> Int
261
   -> Word16
262
   -> [StgWord]
263
   -> Bool      -- True <=> is a return point, rather than a function
264
   -> [FFIInfo]
265
   -> ProtoBCO name
266
mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
267
   = ProtoBCO {
268
        protoBCOName = nm,
269
        protoBCOInstrs = maybe_with_stack_check,
270 271 272 273
        protoBCOBitmap = bitmap,
        protoBCOBitmapSize = bitmap_size,
        protoBCOArity = arity,
        protoBCOExpr = origin,
274
        protoBCOFFIs = ffis
275
      }
276
     where
277 278 279 280
        -- Overestimate the stack usage (in words) of this BCO,
        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
        -- stack check.  (The interpreter always does a stack check
        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
Thomas Schilling's avatar
Thomas Schilling committed
281
        -- BCO anyway, so we only need to add an explicit one in the
282 283
        -- (hopefully rare) cases when the (overestimated) stack use
        -- exceeds iNTERP_STACK_CHECK_THRESH.
284
        maybe_with_stack_check
285
           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
286 287 288
                -- don't do stack checks at return points,
                -- everything is aggregated up to the top BCO
                -- (which must be a function).
289 290
                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
                -- see bug #1466.
291
           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
292
           = STKCHECK stack_usage : peep_d
293
           | otherwise
294 295
           = peep_d     -- the supposedly common case

296
        -- We assume that this sum doesn't wrap
297
        stack_usage = sum (map bciStackUse peep_d)
298 299 300 301

        -- Merge local pushes
        peep_d = peep (fromOL instrs_ordlist)

302 303 304
        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
        peep (PUSH_L off1 : PUSH_L off2 : rest)
305
           = PUSH_LL off1 (off2-1) : peep rest
306 307 308 309 310
        peep (i:rest)
           = i : peep rest
        peep []
           = []

Simon Marlow's avatar
Simon Marlow committed
311
argBits :: DynFlags -> [ArgRep] -> [Bool]
312 313
argBits _      [] = []
argBits dflags (rep : args)
Simon Marlow's avatar
Simon Marlow committed
314 315
  | isFollowableArg rep  = False : argBits dflags args
  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
316

317 318 319 320 321
-- -----------------------------------------------------------------------------
-- schemeTopBind

-- Compile code for the right-hand side of a top-level binding

322
schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
323
schemeTopBind (id, rhs)
324
  | Just data_con <- isDataConWorkId_maybe id,
325
    isNullaryRepDataCon data_con = do
326
    dflags <- getDynFlags
327 328 329 330 331 332 333
        -- Special case for the worker of a nullary data con.
        -- It'll look like this:        Nil = /\a -> Nil a
        -- If we feed it into schemeR, we'll get
        --      Nil = Nil
        -- because mkConAppCode treats nullary constructor applications
        -- by just re-using the single top-level definition.  So
        -- for the worker itself, we must allocate it directly.
334
    -- ioToBc (putStrLn $ "top level BCO")
335
    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
336
                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
337 338 339 340

  | otherwise
  = schemeR [{- No free variables -}] (id, rhs)

341

342 343
-- -----------------------------------------------------------------------------
-- schemeR
344

345 346 347 348 349
-- Compile code for a right-hand side, to give a BCO that,
-- when executed with the free variables and arguments on top of the stack,
-- will return with a pointer to the result on top of the stack, after
-- removing the free variables and arguments.
--
350 351
-- Park the resulting BCO in the monad.  Also requires the
-- variable to which this value was bound, so as to give the
352
-- resulting BCO a name.
353

354 355 356
schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                -- will appear in the thunk.  Empty for
                                -- top-level things, which have no free vars.
357
        -> (Id, AnnExpr Id DVarSet)
358
        -> BcM (ProtoBCO Name)
359
schemeR fvs (nm, rhs)
360
{-
361 362
   | trace (showSDoc (
              (char ' '
363
               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
364 365 366 367 368
               $$ pprCoreExpr (deAnnotate rhs)
               $$ char ' '
              ))) False
   = undefined
   | otherwise
369
-}
370
   = schemeR_wrk fvs nm rhs (collect rhs)
371

372
collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
373 374 375
collect (_, e) = go [] e
  where
    go xs e | Just e' <- bcView e = go xs e'
376
    go xs (AnnLam x (_,e))
Richard Eisenberg's avatar
Richard Eisenberg committed
377
      | typePrimRep (idType x) `lengthExceeds` 1
378
      = multiValException
379 380 381
      | otherwise
      = go (x:xs) e
    go xs not_lambda = (reverse xs, not_lambda)
382

383 384 385 386 387 388
schemeR_wrk
    :: [Id]
    -> Id
    -> AnnExpr Id DVarSet
    -> ([Var], AnnExpr' Var DVarSet)
    -> BcM (ProtoBCO Name)
389
schemeR_wrk fvs nm original_body (args, body)
390 391 392
   = do
     dflags <- getDynFlags
     let
393 394 395 396 397
         all_args  = reverse args ++ fvs
         arity     = length all_args
         -- all_args are the args in reverse order.  We're compiling a function
         -- \fv1..fvn x1..xn -> e
         -- i.e. the fvs come first
398

399 400 401 402 403
         -- Stack arguments always take a whole number of words, we never pack
         -- them unlike constructor fields.
         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
         sum_szsb_args  = sum szsb_args
         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
404

405
         -- make the arg bitmap
Simon Marlow's avatar
Simon Marlow committed
406
         bits = argBits dflags (reverse (map bcIdArgRep all_args))
407
         bitmap_size = genericLength bits
408
         bitmap = mkBitmap dflags bits
409
     body_code <- schemeER_wrk sum_szsb_args p_init body
410

411
     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
412
                 arity bitmap_size bitmap False{-not alts-})
413

414
-- introduce break instructions for ticked expressions
415
schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
416
schemeER_wrk d p rhs
417
  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
418
  = do  code <- schemeE d 0 p newRhs
419
        cc_arr <- getCCArray
420
        this_mod <- moduleName <$> getCurrentModule
421 422
        dflags <- getDynFlags
        let idOffSets = getVarOffSets dflags d p fvs
423 424 425
        let breakInfo = CgBreakInfo
                        { cgb_vars = idOffSets
                        , cgb_resty = exprType (deAnnotate' newRhs)
426
                        }
427
        newBreakInfo tick_no breakInfo
428 429 430
        dflags <- getDynFlags
        let cc | interpreterProfiled dflags = cc_arr ! tick_no
               | otherwise = toRemotePtr nullPtr
431
        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
432
        return $ breakInstr `consOL` code
433
   | otherwise = schemeE d 0 p rhs
434

435 436
getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
getVarOffSets dflags depth env = catMaybes . map getOffSet
437 438
  where
    getOffSet id = case lookupBCEnv_maybe id env of
439
        Nothing     -> Nothing
440 441
        Just offset ->
            -- michalt: I'm not entirely sure why we need the stack
Gabor Greif's avatar
Gabor Greif committed
442
            -- adjustment by 2 here. I initially thought that there's
443 444
            -- something off with getIdValFromApStack (the only user of this
            -- value), but it looks ok to me. My current hypothesis is that
Gabor Greif's avatar
Gabor Greif committed
445
            -- this "adjustment" is needed due to stack manipulation for
446 447
            -- BRK_FUN in Interpreter.c In any case, this is used only when
            -- we trigger a breakpoint.
448 449 450
            let !var_depth_ws =
                    trunc16W $ bytesToWords dflags (depth - offset) + 2
            in Just (id, var_depth_ws)
pcapriotti's avatar
pcapriotti committed
451

452 453
truncIntegral16 :: Integral a => a -> Word16
truncIntegral16 w
pcapriotti's avatar
pcapriotti committed
454 455 456 457
    | w > fromIntegral (maxBound :: Word16)
    = panic "stack depth overflow"
    | otherwise
    = fromIntegral w
458

459 460 461
trunc16B :: ByteOff -> Word16
trunc16B = truncIntegral16

462 463 464
trunc16W :: WordOff -> Word16
trunc16W = truncIntegral16

465
fvsToEnv :: BCEnv -> DVarSet -> [Id]
466 467 468 469 470 471 472 473
-- Takes the free variables of a right-hand side, and
-- delivers an ordered list of the local variables that will
-- be captured in the thunk for the RHS
-- The BCEnv argument tells which variables are in the local
-- environment: these are the ones that should be captured
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
474
fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
475 476
                      isId v,           -- Could be a type variable
                      v `Map.member` p]
477

478 479
-- -----------------------------------------------------------------------------
-- schemeE
480

481 482 483 484 485 486 487
returnUnboxedAtom
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> AnnExpr' Id DVarSet
    -> ArgRep
    -> BcM BCInstrList
488 489
-- Returning an unlifted value.
-- Heave it on the stack, SLIDE, and RETURN.
490 491 492 493 494 495
returnUnboxedAtom d s p e e_rep = do
    dflags <- getDynFlags
    (push, szb) <- pushAtom d p e
    return (push                                 -- value onto stack
           `appOL`  mkSlideB dflags szb (d - s)  -- clear to sequel
           `snocOL` RETURN_UBX e_rep)            -- go
496

497 498
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
499 500
schemeE
    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
501 502 503 504
schemeE d s p e
   | Just e' <- bcView e
   = schemeE d s p e'

505
-- Delegate tail-calls to schemeT.
506
schemeE d s p e@(AnnApp _ _) = schemeT d s p e
507

Simon Marlow's avatar
Simon Marlow committed
508 509
schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
510

511
schemeE d s p e@(AnnVar v)
512
    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
513
    | otherwise                 = schemeT d s p e
514

515 516
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
   | (AnnVar v, args_r_to_l) <- splitApp rhs,
517
     Just data_con <- isDataConWorkId_maybe v,
518
     dataConRepArity data_con == length args_r_to_l
519
   = do -- Special case for a non-recursive let whose RHS is a
Gabor Greif's avatar
Gabor Greif committed
520
        -- saturated constructor application.
521
        -- Just allocate the constructor and carry on
522
        alloc_code <- mkConAppCode d s p data_con args_r_to_l
523 524
        dflags <- getDynFlags
        let !d2 = d + wordSize dflags
525
        body_code <- schemeE d2 s (Map.insert x d2 p) body
526
        return (alloc_code `appOL` body_code)
527 528 529

-- General case for let.  Generates correct, if inefficient, code in
-- all situations.
530 531 532
schemeE d s p (AnnLet binds (_,body)) = do
     dflags <- getDynFlags
     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
533
                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
534
         n_binds = genericLength xs
535

536
         fvss  = map (fvsToEnv p' . fst) rhss
537

sof's avatar
sof committed
538
         -- Sizes of free vars
539 540
         size_w = trunc16W . idSizeW dflags
         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
541

542 543
         -- the arity of each rhs
         arities = map (genericLength . fst . collect) rhss
544 545

         -- This p', d' defn is safe because all the items being pushed
546
         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
547 548
         -- after the closures have been allocated in the heap (but not
         -- filled in), and pointers to them parked on the stack.
549 550 551 552
         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
         p' = Map.insertList (zipE xs offsets) p
         d' = d + wordsToBytes dflags n_binds
         zipE = zipEqual "schemeE"
553 554

         -- ToDo: don't build thunks for things with no free variables
555 556 557 558 559 560 561 562
         build_thunk
             :: StackDepth
             -> [Id]
             -> Word16
             -> ProtoBCO Name
             -> Word16
             -> Word16
             -> BcM BCInstrList
Ian Lynagh's avatar
Ian Lynagh committed
563
         build_thunk _ [] size bco off arity
564
            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
565 566 567
           where
                mkap | arity == 0 = MKAP
                     | otherwise  = MKPAP
568
         build_thunk dd (fv:fvs) size bco off arity = do
569 570 571
              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
              more_push_code <-
                  build_thunk (dd + pushed_szb) fvs size bco off arity
572
              return (push_code `appOL` more_push_code)
573

574
         alloc_code = toOL (zipWith mkAlloc sizes arities)
575
           where mkAlloc sz 0
576 577
                    | is_tick     = ALLOC_AP_NOUPD sz
                    | otherwise   = ALLOC_AP sz
578
                 mkAlloc sz arity = ALLOC_PAP arity sz
579

580
         is_tick = case binds of
581 582 583
                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
                     _other -> False

584 585 586
         compile_bind d' fvs x rhs size arity off = do
                bco <- schemeR fvs (x,rhs)
                build_thunk d' fvs size bco off arity
587

588
         compile_binds =
589
            [ compile_bind d' fvs x rhs size arity (trunc16W n)
590 591 592
            | (fvs, x, rhs, size, arity, n) <-
                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
            ]
593
     body_code <- schemeE d' s p' body
594
     thunk_codes <- sequence compile_binds
595
     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
596

597
-- Introduce a let binding for a ticked case expression. This rule
598 599 600 601 602
-- *should* only fire when the expression was not already let-bound
-- (the code gen for let bindings should take care of that).  Todo: we
-- call exprFreeVars on a deAnnotated expression, this may not be the
-- best way to calculate the free vars but it seemed like the least
-- intrusive thing to do
603
schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
604 605 606 607 608 609 610 611
   | isLiftedTypeKind (typeKind ty)
   = do   id <- newId ty
          -- Todo: is emptyVarSet correct on the next line?
          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
          schemeE d s p letExp

   | otherwise
   = do   -- If the result type is not definitely lifted, then we must generate
612
          --   let f = \s . tick<n> e
613 614 615 616
          --   in  f realWorld#
          -- When we stop at the breakpoint, _result will have an unlifted
          -- type and hence won't be bound in the environment, but the
          -- breakpoint will otherwise work fine.
617
          --
618
          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where
619 620 621 622 623 624 625 626
          --    r :: RuntimeRep is a variable. This can happen in the
          --    continuations for a pattern-synonym matcher
          --    match = /\(r::RuntimeRep) /\(a::TYPE r).
          --            \(k :: Int -> a) \(v::T).
          --            case v of MkV n -> k n
          -- Here (k n) :: a :: Type r, so we don't know if it's lifted
          -- or not; but that should be fine provided we add that void arg.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
627
          id <- newId (mkVisFunTy realWorldStatePrimTy ty)
628
          st <- newId realWorldStatePrimTy
629 630 631
          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
                                                    (emptyDVarSet, AnnVar realWorldPrimId)))
632
          schemeE d s p letExp
633 634 635 636 637

   where
     exp' = deAnnotate' exp
     fvs  = exprFreeVarsDSet exp'
     ty   = exprType exp'
638

639 640 641
-- ignore other kinds of tick
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs

642 643 644
schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
        -- no alts: scrut is guaranteed to diverge

645
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
646
   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
647
        -- Convert
Simon Marlow's avatar
Simon Marlow committed
648
        --      case .... of x { (# V'd-thing, a #) -> ... }
649 650
        -- to
        --      case .... of a { DEFAULT -> ... }
Gabor Greif's avatar
Gabor Greif committed
651
        -- because the return convention for both are identical.
652 653 654
        --
        -- Note that it does not matter losing the void-rep thing from the
        -- envt (it won't be bound now) because we never look such things up.
Richard Eisenberg's avatar
Richard Eisenberg committed
655 656
   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
                   ([], [_])
657
                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
Richard Eisenberg's avatar
Richard Eisenberg committed
658
                   ([_], [])
659
                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
Richard Eisenberg's avatar
Richard Eisenberg committed
660
                   _ -> Nothing
661 662 663
   = res

schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
664
   | isUnboxedTupleCon dc
665
   , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
666 667 668 669
   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)

schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
   | isUnboxedTupleType (idType bndr)
Richard Eisenberg's avatar
Richard Eisenberg committed
670 671 672 673
   , Just ty <- case typePrimRep (idType bndr) of
       [_]  -> Just (unwrapType (idType bndr))
       []   -> Just voidPrimTy
       _    -> Nothing
674 675 676
       -- handles any pattern with a single non-void binder; in particular I/O
       -- monad returns (# RealWorld#, a #)
   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
677

678
schemeE d s p (AnnCase scrut bndr _ alts)
679
   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
680

Ian Lynagh's avatar
Ian Lynagh committed
681
schemeE _ _ _ expr
682
   = pprPanic "ByteCodeGen.schemeE: unhandled case"
Ian Lynagh's avatar
Ian Lynagh committed
683
               (pprCoreExpr (deAnnotate' expr))
684

685
{-
686 687
   Ticked Expressions
   ------------------
688

689
  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
690
  the code. When we find such a thing, we pull out the useful information,
691
  and then compile the code as if it was just the expression E.
692 693 694

-}

695 696 697 698 699
-- Compile code to do a tail call.  Specifically, push the fn,
-- slide the on-stack app back down to the sequel depth,
-- and enter.  Four cases:
--
-- 0.  (Nasty hack).
700
--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
701 702
--     The int will be on the stack.  Generate a code sequence
--     to convert it to the relevant constructor, SLIDE and ENTER.
703
--
704
-- 1.  The fn denotes a ccall.  Defer to generateCCall.
705
--
Simon Marlow's avatar
Simon Marlow committed
706
-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat
707
--     it simply as  b  -- since the representations are identical
Simon Marlow's avatar
Simon Marlow committed
708
--     (the V takes up zero stack space).  Also, spot
709
--     (# b #) and treat it as  b.
710
--
711
-- 3.  Application of a constructor, by defn saturated.
712
--     Split the args into ptrs and non-ptrs, and push the nonptrs,
713 714
--     then the ptrs, and then do PACK and RETURN.
--
715
-- 4.  Otherwise, it must be a function call.  Push the args
716
--     right to left, SLIDE and ENTER.
717

718
schemeT :: StackDepth   -- Stack depth
719 720
        -> Sequel       -- Sequel depth
        -> BCEnv        -- stack env
721
        -> AnnExpr' Id DVarSet
722
        -> BcM BCInstrList
723

724
schemeT d s p app
725

726
   -- Case 0
727 728
   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
   = implement_tagToId d s p arg constr_names
729

730
   -- Case 1
731
   | Just (CCall ccall_spec) <- isFCallId_maybe fn
732 733 734 735
   = if isSupportedCConv ccall_spec
      then generateCCall d s p ccall_spec fn args_r_to_l
      else unsupportedCConvException

736

737
   -- Case 2: Constructor application
738 739
   | Just con <- maybe_saturated_dcon
   , isUnboxedTupleCon con
740
   = case args_r_to_l of
Simon Marlow's avatar
Simon Marlow committed
741
        [arg1,arg2] | isVAtom arg1 ->
742
                  unboxedTupleReturn d s p arg2
Simon Marlow's avatar
Simon Marlow committed
743
        [arg1,arg2] | isVAtom arg2 ->
744
                  unboxedTupleReturn d s p arg1
745
        _other -> multiValException
746 747

   -- Case 3: Ordinary data constructor
748
   | Just con <- maybe_saturated_dcon
749
   = do alloc_con <- mkConAppCode d s p con args_r_to_l
750
        dflags <- getDynFlags
751
        return (alloc_con         `appOL`
752
                mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
753
                ENTER)
754

755
   -- Case 4: Tail call of function
756
   | otherwise
757
   = doTailCall d s p fn args_r_to_l
758

759
   where
760 761 762
        -- Extract the args (R->L) and fn
        -- The function will necessarily be a variable,
        -- because we are compiling a tail call
763
      (AnnVar fn, args_r_to_l) = splitApp app
764

765
      -- Only consider this to be a constructor application iff it is
766
      -- saturated.  Otherwise, we'll call the constructor wrapper.
767
      n_args = length args_r_to_l
768 769 770 771
      maybe_saturated_dcon
        = case isDataConWorkId_maybe fn of
                Just con | dataConRepArity con == n_args -> Just con
                _ -> Nothing
772

773
-- -----------------------------------------------------------------------------
774
-- Generate code to build a constructor application,
775 776
-- leaving it on top of the stack

777 778 779 780 781 782 783
mkConAppCode
    :: StackDepth
    -> Sequel
    -> BCEnv
    -> DataCon                  -- The data constructor
    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
    -> BcM BCInstrList
784
mkConAppCode _ _ _ con []       -- Nullary constructor
785
  = ASSERT( isNullaryRepDataCon con )
786
    return (unitOL (PUSH_G (getName (dataConWorkId con))))
787 788
        -- Instead of doing a PACK, which would allocate a fresh
        -- copy of this constructor, use the single shared version.
789

790 791 792 793 794
mkConAppCode orig_d _ p con args_r_to_l =
    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
  where
    app_code = do
        dflags <- getDynFlags
795

796 797 798 799 800 801 802 803
        -- The args are initially in reverse order, but mkVirtHeapOffsets
        -- expects them to be left-to-right.
        let non_voids =
                [ NonVoid (prim_rep, arg)
                | arg <- reverse args_r_to_l
                , let prim_rep = atomPrimRep arg
                , not (isVoidRep prim_rep)
                ]
804
            (_, _, args_offsets) =
Simon Marlow's avatar
Simon Marlow committed
805
                mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
806

807 808
            do_pushery !d (arg : args) = do
                (push, arg_bytes) <- case arg of
Michal Terepeta's avatar
Michal Terepeta committed
809
                    (Padding l _) -> return $! pushPadding