diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index 3f88187960613f2ad8d0258c2dada56bc1885f88..c58328f57c7eb7ba8611c1674a762b901b974fc1 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -9,10 +9,10 @@
-- | Bytecode assembler and linker
module GHC.ByteCode.Asm (
assembleBCOs, assembleOneBCO,
-
bcoFreeNames,
SizedSeq, sizeSS, ssElts,
- iNTERP_STACK_CHECK_THRESH
+ iNTERP_STACK_CHECK_THRESH,
+ mkTupleInfoLit
) where
#include "HsVersions.h"
@@ -27,7 +27,7 @@ import GHC.ByteCode.InfoTable
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
-import GHC.Runtime.Heap.Layout
+import GHC.Runtime.Heap.Layout hiding ( WordOff )
import GHC.Types.Name
import GHC.Types.Name.Set
@@ -381,6 +381,16 @@ assembleI platform i = case i of
-> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
+ PUSH_ALTS_TUPLE proto tuple_info tuple_proto
+ -> do let ul_bco = assembleBCO platform proto
+ ul_tuple_bco = assembleBCO platform
+ tuple_proto
+ p <- ioptr (liftM BCOPtrBCO ul_bco)
+ p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
+ info <- int (fromIntegral $
+ mkTupleInfoSig tuple_info)
+ emit bci_PUSH_ALTS_T
+ [Op p, Op info, Op p_tup]
PUSH_PAD8 -> emit bci_PUSH_PAD8 []
PUSH_PAD16 -> emit bci_PUSH_PAD16 []
PUSH_PAD32 -> emit bci_PUSH_PAD32 []
@@ -439,6 +449,7 @@ assembleI platform i = case i of
ENTER -> emit bci_ENTER []
RETURN -> emit bci_RETURN []
RETURN_UBX rep -> emit (return_ubx rep) []
+ RETURN_TUPLE -> emit bci_RETURN_T []
CCALL off m_addr i -> do np <- addr m_addr
emit bci_CCALL [SmallOp off, Op np, SmallOp i]
BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
@@ -516,6 +527,90 @@ return_ubx V16 = error "return_ubx: vector"
return_ubx V32 = error "return_ubx: vector"
return_ubx V64 = error "return_ubx: vector"
+{-
+ we can only handle up to a fixed number of words on the stack,
+ because we need a stg_ctoi_tN stack frame for each size N. See
+ Note [unboxed tuple bytecodes and tuple_BCO].
+
+ If needed, you can support larger tuples by adding more in
+ StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
+ raising this limit.
+
+ Note that the limit is the number of words passed on the stack.
+ If the calling convention passes part of the tuple in registers, the
+ maximum number of tuple elements may be larger. Elements can also
+ take multiple words on the stack (for example Double# on a 32 bit
+ platform).
+
+ -}
+maxTupleNativeStackSize :: WordOff
+maxTupleNativeStackSize = 62
+
+{-
+ Maximum number of supported registers for returning tuples.
+
+ If GHC uses more more than these (because of a change in the calling
+ convention or a new platform) mkTupleInfoSig will panic.
+
+ You can raise the limits after modifying stg_ctoi_t and stg_ret_t
+ (StgMiscClosures.cmm) to save and restore the additional registers.
+ -}
+maxTupleVanillaRegs, maxTupleFloatRegs, maxTupleDoubleRegs,
+ maxTupleLongRegs :: Int
+maxTupleVanillaRegs = 6
+maxTupleFloatRegs = 6
+maxTupleDoubleRegs = 6
+maxTupleLongRegs = 1
+
+{-
+ Construct the tuple_info word that stg_ctoi_t and stg_ret_t use
+ to convert a tuple between the native calling convention and the
+ interpreter.
+
+ See Note [GHCi tuple layout] for more information.
+ -}
+mkTupleInfoSig :: TupleInfo -> Word32
+mkTupleInfoSig ti@TupleInfo{..}
+ | tupleNativeStackSize > maxTupleNativeStackSize =
+ pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"
+ (ppr tupleNativeStackSize <+> text "stack words." <+>
+ text "Use -fobject-code to get around this limit"
+ )
+ | tupleVanillaRegs `shiftR` maxTupleVanillaRegs /= 0 =
+ pprPanic "mkTupleInfoSig: too many vanilla registers" (ppr tupleVanillaRegs)
+ | tupleLongRegs `shiftR` maxTupleLongRegs /= 0 =
+ pprPanic "mkTupleInfoSig: too many long registers" (ppr tupleLongRegs)
+ | tupleFloatRegs `shiftR` maxTupleFloatRegs /= 0 =
+ pprPanic "mkTupleInfoSig: too many float registers" (ppr tupleFloatRegs)
+ | tupleDoubleRegs `shiftR` maxTupleDoubleRegs /= 0 =
+ pprPanic "mkTupleInfoSig: too many double registers" (ppr tupleDoubleRegs)
+ {-
+ Check that we can pack the register counts/bitmaps and stack size
+ in the information word. In particular we check that each component
+ fits in the bits we have reserved for it.
+
+ This overlaps with some of the above checks. It's likely that if the
+ number of registers changes, the number of bits will also need to be
+ updated.
+ -}
+ | tupleNativeStackSize < 16384 && -- 14 bits stack usage
+ tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float)
+ tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double)
+ tupleLongRegs < 4 && -- 2 bit bitmap
+ tupleVanillaRegs < 65536 && -- 4 bit count (tupleVanillaRegs is still a bitmap)
+ -- check that there are no "holes", i.e. that R1..Rn are all in use
+ tupleVanillaRegs .&. (tupleVanillaRegs + 1) == 0
+ = fromIntegral tupleNativeStackSize .|.
+ unRegBitmap (tupleLongRegs `shiftL` 14) .|.
+ unRegBitmap (tupleDoubleRegs `shiftL` 16) .|.
+ unRegBitmap (tupleFloatRegs `shiftL` 22) .|.
+ fromIntegral (countTrailingZeros (1 + tupleVanillaRegs) `shiftL` 28)
+ | otherwise = pprPanic "mkTupleInfoSig: unsupported tuple shape" (ppr ti)
+
+mkTupleInfoLit :: Platform -> TupleInfo -> Literal
+mkTupleInfoLit platform tuple_info =
+ mkLitWord platform . fromIntegral $ mkTupleInfoSig tuple_info
+
-- Make lists of host-sized words for literals, so that when the
-- words are placed in memory at increasing addresses, the
-- bit pattern is correct for the host's word size and endianness.
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index a8cc569548b6296b82018f30f69dc5c6fbba1f33..5b0b20e38d2a42387f346148d4c554099d0800b4 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -17,22 +18,19 @@ import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import GHC.StgToCmm.Layout ( ArgRep(..) )
-import GHC.Core.Ppr
import GHC.Utils.Outputable
-import GHC.Data.FastString
import GHC.Types.Name
import GHC.Types.Unique
-import GHC.Types.Id
-import GHC.Core
import GHC.Types.Literal
import GHC.Core.DataCon
-import GHC.Types.Var.Set
import GHC.Builtin.PrimOps
import GHC.Runtime.Heap.Layout
import Data.Word
import GHC.Stack.CCS (CostCentre)
+import GHC.Stg.Syntax
+
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -45,7 +43,7 @@ data ProtoBCO a
protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
-- what the BCO came from, for debugging only
- protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
+ protoBCOExpr :: Either [CgStgAlt] CgStgRhs,
-- malloc'd pointers
protoBCOFFIs :: [FFIInfo]
}
@@ -91,6 +89,9 @@ data BCInstr
-- Push an alt continuation
| PUSH_ALTS (ProtoBCO Name)
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+ | PUSH_ALTS_TUPLE (ProtoBCO Name) -- continuation
+ !TupleInfo
+ (ProtoBCO Name) -- tuple return BCO
-- Pushing 8, 16 and 32 bits of padding (for constructors).
| PUSH_PAD8
@@ -173,8 +174,9 @@ data BCInstr
-- To Infinity And Beyond
| ENTER
- | RETURN -- return a lifted value
+ | RETURN -- return a lifted value
| RETURN_UBX ArgRep -- return an unlifted value, here's its rep
+ | RETURN_TUPLE -- return an unboxed tuple (info already on stack)
-- Breakpoints
| BRK_FUN Word16 Unique (RemotePtr CostCentre)
@@ -193,36 +195,45 @@ instance Outputable a => Outputable (ProtoBCO a) where
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
<+> text (show ffis) <> colon)
$$ nest 3 (case origin of
- Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
- (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
- Right rhs -> pprCoreExprShort (deAnnotate rhs))
+ Left alts ->
+ vcat (zipWith (<+>) (char '{' : repeat (char ';'))
+ (map (pprStgAltShort shortStgPprOpts) alts))
+ Right rhs ->
+ pprStgRhsShort shortStgPprOpts rhs
+ )
$$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
$$ nest 3 (vcat (map ppr instrs))
--- Print enough of the Core expression to enable the reader to find
--- the expression in the -ddump-prep output. That is, we need to
+-- Print enough of the STG expression to enable the reader to find
+-- the expression in the -ddump-stg output. That is, we need to
-- include at least a binder.
-pprCoreExprShort :: CoreExpr -> SDoc
-pprCoreExprShort expr@(Lam _ _)
- = let
- (bndrs, _) = collectBinders expr
- in
- char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
-
-pprCoreExprShort (Case _expr var _ty _alts)
- = text "case of" <+> ppr var
-
-pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
-pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
-
-pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
-pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
+pprStgExprShort :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc
+pprStgExprShort _ (StgCase _expr var _ty _alts) =
+ text "case of" <+> ppr var
+pprStgExprShort _ (StgLet _ bnd _) =
+ text "let" <+> pprStgBindShort bnd <+> text "in ..."
+pprStgExprShort _ (StgLetNoEscape _ bnd _) =
+ text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..."
+pprStgExprShort opts (StgTick t e) = ppr t <+> pprStgExprShort opts e
+pprStgExprShort opts e = pprStgExpr opts e
+
+pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc
+pprStgBindShort (StgNonRec x _) =
+ ppr x <+> text "= ..."
+pprStgBindShort (StgRec bs) =
+ char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"
+
+pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc
+pprStgAltShort opts (con, args, expr) =
+ ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr
+
+pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
+pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) =
+ hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])
+ 4 (pprStgExprShort opts body)
+pprStgRhsShort opts rhs = pprStgRhs opts rhs
-pprCoreExprShort e = pprCoreExpr e
-
-pprCoreAltShort :: CoreAlt -> SDoc
-pprCoreAltShort (Alt con args expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
instance Outputable BCInstr where
ppr (STKCHECK n) = text "STKCHECK" <+> ppr n
@@ -239,8 +250,13 @@ instance Outputable BCInstr where
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
+
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+ ppr (PUSH_ALTS_TUPLE bco tuple_info tuple_bco) =
+ hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)
+ 2
+ (ppr tuple_bco $+$ ppr bco)
ppr PUSH_PAD8 = text "PUSH_PAD8"
ppr PUSH_PAD16 = text "PUSH_PAD16"
@@ -297,8 +313,11 @@ instance Outputable BCInstr where
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
+ ppr (RETURN_TUPLE) = text "RETURN_TUPLE"
ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
+
+
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
-- correct, or overestimates of reality, to be safe.
@@ -326,8 +345,16 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
-bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS bco) = 2 {- profiling only, restore CCCS -} +
+ 3 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +
+ 4 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_TUPLE bco info _) =
+ -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)
+ -- tuple
+ -- (tuple_info, tuple_bco, stg_ret_t)
+ 1 {- profiling only -} +
+ 7 + fromIntegral (tupleSize info) + protoBCOStackUse bco
bciStackUse (PUSH_PAD8) = 1 -- overapproximation
bciStackUse (PUSH_PAD16) = 1 -- overapproximation
bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
@@ -365,7 +392,8 @@ bciStackUse CASEFAIL{} = 0
bciStackUse JMP{} = 0
bciStackUse ENTER{} = 0
bciStackUse RETURN{} = 0
-bciStackUse RETURN_UBX{} = 1
+bciStackUse RETURN_UBX{} = 1 -- pushes stg_ret_X for some X
+bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header
bciStackUse CCALL{} = 0
bciStackUse SWIZZLE{} = 0
bciStackUse BRK_FUN{} = 0
diff --git a/compiler/GHC/ByteCode/Types.hs b/compiler/GHC/ByteCode/Types.hs
index 97304cb7f4561fe709afe4ff02a38c68b7e40692..02c117d716a851bc4543e93679c77cc4b80504e4 100644
--- a/compiler/GHC/ByteCode/Types.hs
+++ b/compiler/GHC/ByteCode/Types.hs
@@ -6,7 +6,11 @@
-- | Bytecode assembler types
module GHC.ByteCode.Types
- ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
+ ( CompiledByteCode(..), seqCompiledByteCode
+ , FFIInfo(..)
+ , RegBitmap(..)
+ , TupleInfo(..), voidTupleInfo
+ , ByteOff(..), WordOff(..)
, UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
, ItblEnv, ItblPtr(..)
, CgBreakInfo(..)
@@ -68,6 +72,61 @@ seqCompiledByteCode CompiledByteCode{..} =
rnf bc_strs `seq`
rnf (fmap seqModBreaks bc_breaks)
+newtype ByteOff = ByteOff Int
+ deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)
+
+newtype WordOff = WordOff Int
+ deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)
+
+newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 }
+ deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable)
+
+{- Note [GHCi TupleInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~
+
+ This contains the data we need for passing unboxed tuples between
+ bytecode and native code
+
+ In general we closely follow the native calling convention that
+ GHC uses for unboxed tuples, but we don't use any registers in
+ bytecode. All tuple elements are expanded to use a full register
+ or a full word on the stack.
+
+ The position of tuple elements that are returned on the stack in
+ the native calling convention is unchanged when returning the same
+ tuple in bytecode.
+
+ The order of the remaining elements is determined by the register in
+ which they would have been returned, rather than by their position in
+ the tuple in the Haskell source code. This makes jumping between bytecode
+ and native code easier: A map of live registers is enough to convert the
+ tuple.
+
+ See GHC.StgToByteCode.layoutTuple for more details.
+-}
+data TupleInfo = TupleInfo
+ { tupleSize :: !WordOff -- total size of tuple in words
+ , tupleVanillaRegs :: !RegBitmap -- vanilla registers used
+ , tupleLongRegs :: !RegBitmap -- long registers used
+ , tupleFloatRegs :: !RegBitmap -- float registers used
+ , tupleDoubleRegs :: !RegBitmap -- double registers used
+ , tupleNativeStackSize :: !WordOff {- words spilled on the stack by
+ GHCs native calling convention -}
+ } deriving (Show)
+
+instance Outputable TupleInfo where
+ ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>
+ text "stack" <+> ppr tupleNativeStackSize <+>
+ text "regs" <+>
+ char 'R' <> ppr tupleVanillaRegs <+>
+ char 'L' <> ppr tupleLongRegs <+>
+ char 'F' <> ppr tupleFloatRegs <+>
+ char 'D' <> ppr tupleDoubleRegs <>
+ char '>'
+
+voidTupleInfo :: TupleInfo
+voidTupleInfo = TupleInfo 0 0 0 0 0 0
+
type ItblEnv = NameEnv (Name, ItblPtr)
-- We need the Name in the range so we know which
-- elements to filter out when unloading a module
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index 2c68439dc0fc378e4d36a07c90644766f45dd4d6..86b06271d18fb9dd4b73e1513259f1173566b7c7 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -522,6 +522,8 @@ instance Eq GlobalReg where
PicBaseReg == PicBaseReg = True
_r1 == _r2 = False
+-- NOTE: this Ord instance affects the tuple layout in GHCi, see
+-- Note [GHCi tuple layout]
instance Ord GlobalReg where
compare (VanillaReg i _) (VanillaReg j _) = compare i j
-- Ignore type when seeking clashes
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index 7edc0d7a28ad2e59bcd4e7df8393539613e8749c..a3ea0bb1d3f83cbf4ce988a9de28f5dc085baf4e 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -17,6 +17,8 @@ module GHC.Core.Lint (
lintPassResult, lintInteractiveExpr, lintExpr,
lintAnnots, lintAxioms,
+ interactiveInScope,
+
-- ** Debug output
endPass, endPassIO,
displayLintResults, dumpPassResult,
@@ -379,7 +381,7 @@ lintPassResult hsc_env pass binds
| not (gopt Opt_DoCoreLinting dflags)
= return ()
| otherwise
- = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+ = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds
; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass)
; displayLintResults logger dflags (showLintWarnings pass) (ppr pass)
(pprCoreBindings binds) warns_and_errs }
@@ -432,7 +434,7 @@ lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
lintInteractiveExpr what hsc_env expr
| not (gopt Opt_DoCoreLinting dflags)
= return ()
- | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
+ | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr
= displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err)
| otherwise
= return ()
@@ -440,7 +442,7 @@ lintInteractiveExpr what hsc_env expr
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
-interactiveInScope :: HscEnv -> [Var]
+interactiveInScope :: InteractiveContext -> [Var]
-- In GHCi we may lint expressions, or bindings arising from 'deriving'
-- clauses, that mention variables bound in the interactive context.
-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context).
@@ -452,11 +454,10 @@ interactiveInScope :: HscEnv -> [Var]
-- so this is a (cheap) no-op.
--
-- See #8215 for an example
-interactiveInScope hsc_env
+interactiveInScope ictxt
= tyvars ++ ids
where
-- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr
- ictxt = hsc_IC hsc_env
(cls_insts, _fam_insts) = ic_instances ictxt
te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)
te = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index b1397fe4e18bf8509b79b178d5e84d0aa7bd4fb5..d8a6dd0e95dc0de5b29c19b6055a98a969c88257 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, DeriveFunctor #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TypeFamilies #-}
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -414,13 +416,9 @@ coreToStgExpr expr@(Lam _ _)
text "Unexpected value lambda:" $$ ppr expr
coreToStgExpr (Tick tick expr)
- = do stg_tick <- case tick of
- HpcTick m i -> return (HpcTick m i)
- ProfNote cc cnt sc -> return (ProfNote cc cnt sc)
- SourceNote span nm -> return (SourceNote span nm)
- Breakpoint{} ->
- panic "coreToStgExpr: breakpoint should not happen"
- expr2 <- coreToStgExpr expr
+ = do
+ let !stg_tick = coreToStgTick (exprType expr) tick
+ !expr2 <- coreToStgExpr expr
return (StgTick stg_tick expr2)
coreToStgExpr (Cast expr _)
@@ -570,12 +568,8 @@ coreToStgApp f args ticks = do
TickBoxOpId {} -> pprPanic "coreToStg TickBox" $ ppr (f,args')
_other -> StgApp f args'
- convert_tick (Breakpoint _ bid fvs) = res_ty `seq` Breakpoint res_ty bid fvs
- convert_tick (HpcTick m i) = HpcTick m i
- convert_tick (SourceNote span nm) = SourceNote span nm
- convert_tick (ProfNote cc cnt scope) = ProfNote cc cnt scope
add_tick !t !e = StgTick t e
- tapp = foldr add_tick app (map convert_tick ticks ++ ticks')
+ tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')
-- Forcing these fixes a leak in the code generator, noticed while
-- profiling for trac #4367
@@ -601,12 +595,7 @@ coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion token
coreToStgArgs (Tick t e : args)
= ASSERT( not (tickishIsCode t) )
do { (args', ts) <- coreToStgArgs (e : args)
- ; let convert_tick (Breakpoint _ bid fvs) =
- let !ty = exprType e in Breakpoint ty bid fvs
- convert_tick (HpcTick m i) = HpcTick m i
- convert_tick (SourceNote span nm) = SourceNote span nm
- convert_tick (ProfNote cc cnt scope) = ProfNote cc cnt scope
- !t' = convert_tick t
+ ; let !t' = coreToStgTick (exprType e) t
; return (args', t':ts) }
coreToStgArgs (arg : args) = do -- Non-type argument
@@ -639,6 +628,13 @@ coreToStgArgs (arg : args) = do -- Non-type argument
WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
return (stg_arg : stg_args, ticks ++ aticks)
+coreToStgTick :: Type -- type of the ticked expression
+ -> CoreTickish
+ -> StgTickish
+coreToStgTick _ty (HpcTick m i) = HpcTick m i
+coreToStgTick _ty (SourceNote span nm) = SourceNote span nm
+coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
+coreToStgTick !ty (Breakpoint _ bid fvs) = Breakpoint ty bid fvs
-- ---------------------------------------------------------------------------
-- The magic for lets:
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index 956175b3ad0c09fc8f9b858ea765fc565d691137..af94cb92d7c7084c1a296dbf215af5a51623066d 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -964,7 +964,7 @@ no further floating will occur. This allows us to safely inline things like
GHC.Magic. This definition is used in cases where runRW is curried.
* In addition to its normal Haskell definition in GHC.Magic, we give it
- a special late inlining here in CorePrep and GHC.CoreToByteCode, avoiding
+ a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding
the incorrect sharing due to float-out noted above.
* It is levity-polymorphic:
diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs
index 845a5f36c09b9d53f48cc9dcaeb8975e728fc3fd..39789607d985999f463a24f671f8e7d7a9cdd4c2 100644
--- a/compiler/GHC/Driver/Backend.hs
+++ b/compiler/GHC/Driver/Backend.hs
@@ -67,10 +67,10 @@ data Backend
-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that
-- can be interpreted. It is used by GHCi.
--
- -- Currently some extensions are not supported (unboxed
- -- tuples/sums, foreign primops).
+ -- Currently some extensions are not supported
+ -- (foreign primops).
--
- -- See "GHC.CoreToByteCode"
+ -- See "GHC.StgToByteCode"
| NoBackend -- ^ No code generated.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index a910cdf23fcac68c3a61040d6033f1ebaa609d74..50e5a0a067365a998f81bc048beae200324af6dc 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -114,7 +114,7 @@ import GHC.Hs.Stats ( ppSourceStats )
import GHC.HsToCore
-import GHC.CoreToByteCode ( byteCodeGen, coreExprToBCOs )
+import GHC.StgToByteCode ( byteCodeGen, stgExprToBCOs )
import GHC.IfaceToCore ( typecheckIface )
@@ -132,6 +132,8 @@ import GHC.Core
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Lint ( lintInteractiveExpr )
+import GHC.Core.Multiplicity
+import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
@@ -156,6 +158,7 @@ import GHC.Stg.Pipeline ( stg2stg )
import GHC.Builtin.Utils
import GHC.Builtin.Names
+import GHC.Builtin.Uniques ( mkPseudoUniqueE )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
@@ -1551,7 +1554,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
withTiming logger dflags
(text "CoreToStg"<+>brackets (ppr this_mod))
(\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())
- (myCoreToStg logger dflags this_mod location prepd_binds)
+ (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds)
let cost_centre_info =
(S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
@@ -1622,8 +1625,12 @@ hscInteractive hsc_env cgguts location = do
-- Do saturation and convert to A-normal form
(prepd_binds, _) <- {-# SCC "CorePrep" #-}
corePrepPgm hsc_env this_mod location core_binds data_tycons
+
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ <- {-# SCC "CoreToStg" #-}
+ myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds
----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
+ comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
------------------ Create f-x-dynamic C-side stuff -----
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
@@ -1760,22 +1767,43 @@ doCodeGen hsc_env this_mod denv data_tycons
return (Stream.mapM dump2 pipeline_stream)
-myCoreToStg :: Logger -> DynFlags -> Module -> ModLocation -> CoreProgram
+myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
+ -> Module -> ModLocation -> CoreExpr
+ -> IO ( StgRhs
+ , InfoTableProvMap
+ , CollectedCCs )
+myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do
+ {- Create a temporary binding (just because myCoreToStg needs a
+ binding for the stg2stg step) -}
+ let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
+ (mkPseudoUniqueE 0)
+ Many
+ (exprType prepd_expr)
+ ([StgTopLifted (StgNonRec _ stg_expr)], prov_map, collected_ccs) <-
+ myCoreToStg logger
+ dflags
+ ictxt
+ this_mod
+ ml
+ [NonRec bco_tmp_id prepd_expr]
+ return (stg_expr, prov_map, collected_ccs)
+
+myCoreToStg :: Logger -> DynFlags -> InteractiveContext
+ -> Module -> ModLocation -> CoreProgram
-> IO ( [StgTopBinding] -- output program
, InfoTableProvMap
, CollectedCCs ) -- CAF cost centre info (declared and used)
-myCoreToStg logger dflags this_mod ml prepd_binds = do
+myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do
let (stg_binds, denv, cost_centre_info)
= {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod ml prepd_binds
stg_binds2
<- {-# SCC "Stg2Stg" #-}
- stg2stg logger dflags this_mod stg_binds
+ stg2stg logger dflags ictxt this_mod stg_binds
return (stg_binds2, denv, cost_centre_info)
-
{- **********************************************************************
%* *
\subsection{Compiling a do-statement}
@@ -1911,9 +1939,18 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
(prepd_binds, _) <- {-# SCC "CorePrep" #-}
liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
+ (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)
+ <- {-# SCC "CoreToStg" #-}
+ liftIO $ myCoreToStg (hsc_logger hsc_env)
+ (hsc_dflags hsc_env)
+ (hsc_IC hsc_env)
+ this_mod
+ iNTERACTIVELoc
+ prepd_binds
+
{- Generate byte code -}
cbc <- liftIO $ byteCodeGen hsc_env this_mod
- prepd_binds data_tycons mod_breaks
+ stg_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
liftIO $ loadDecls hsc_env src_span cbc
@@ -2077,10 +2114,25 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr
{- Lint if necessary -}
; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
+ ; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
+ ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
+ ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
+ ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
+
+ ; let ictxt = hsc_IC hsc_env
+ ; (stg_expr, _, _) <-
+ myCoreToStgExpr (hsc_logger hsc_env)
+ (hsc_dflags hsc_env)
+ ictxt
+ (icInteractiveModule ictxt)
+ iNTERACTIVELoc
+ prepd_expr
{- Convert to BCOs -}
- ; bcos <- coreExprToBCOs hsc_env
- (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+ ; bcos <- stgExprToBCOs hsc_env
+ (icInteractiveModule ictxt)
+ (exprType prepd_expr)
+ stg_expr
{- load it -}
; loadExpr hsc_env srcspan bcos }
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index bd885d904273b51a389fc503673ad2ee473443c6..20fb7ecc8665b3ecdd1535b2489301aa11c0a9fb 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -2267,7 +2267,6 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
let tmpfs = hsc_tmpfs hsc_env
map1 <- case backend dflags of
NoBackend -> enableCodeGenForTH logger tmpfs home_unit default_backend map0
- Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger tmpfs default_backend map0
_ -> return map0
if null errs
then pure $ concat $ modNodeMapElems map1
@@ -2377,33 +2376,8 @@ enableCodeGenForTH logger tmpfs home_unit =
-- can't compile anything anyway! See #16219.
isHomeUnitDefinite home_unit
--- | Update the every ModSummary that is depended on
--- by a module that needs unboxed tuples. We enable codegen to
--- the specified target, disable optimization and change the .hi
--- and .o file locations to be temporary files.
---
--- This is used in order to load code that uses unboxed tuples
--- or sums into GHCi while still allowing some code to be interpreted.
-enableCodeGenForUnboxedTuplesOrSums
- :: Logger
- -> TmpFs
- -> Backend
- -> ModNodeMap [Either ErrorMessages ExtendedModSummary]
- -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])
-enableCodeGenForUnboxedTuplesOrSums logger tmpfs =
- enableCodeGenWhen logger tmpfs condition should_modify TFL_GhcSession TFL_CurrentModule
- where
- condition ms =
- unboxed_tuples_or_sums (ms_hspp_opts ms) &&
- not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&
- (isBootSummary ms == NotBoot)
- unboxed_tuples_or_sums d =
- xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
- should_modify (ModSummary { ms_hspp_opts = dflags }) =
- backend dflags == Interpreter
-
--- | Helper used to implement 'enableCodeGenForTH' and
--- 'enableCodeGenForUnboxedTuples'. In particular, this enables
+-- | Helper used to implement 'enableCodeGenForTH'.
+-- In particular, this enables
-- unoptimized code generation for all modules that meet some
-- condition (first parameter), or are dependencies of those
-- modules. The second parameter is a condition to check before
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index db43ff74acfd20388de80d008d472ee27e494c25..e3ba232add467d864ac7a28f455427f3ad834b3b 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -692,7 +692,7 @@ pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
There are 3 situations where items are removed from the Id list
(or replaced with `Nothing`):
- 1.) If function `GHC.CoreToByteCode.schemeER_wrk` (which creates
+ 1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates
the Id list) doesn't find an Id in the ByteCode environement.
2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint`
filters out unboxed elements from the Id list, because GHCi cannot
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
index 1e12e9bab927e09465463b6abd64eedc0e583f48..8464cb87860a47f2c7dfcce626256dd79ebc211b 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ b/compiler/GHC/Stg/Lint.hs
@@ -42,6 +42,7 @@ import GHC.Prelude
import GHC.Stg.Syntax
import GHC.Driver.Session
+import GHC.Core.Lint ( interactiveInScope )
import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
import GHC.Types.Basic ( TopLevelFlag(..), isTopLevel )
import GHC.Types.CostCentre ( isCurrentCCS )
@@ -57,6 +58,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Unit.Module ( Module )
+import GHC.Runtime.Context ( InteractiveContext )
import qualified GHC.Utils.Error as Err
import Control.Applicative ((<|>))
import Control.Monad
@@ -64,13 +66,14 @@ import Control.Monad
lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
=> Logger
-> DynFlags
+ -> InteractiveContext
-> Module -- ^ module being compiled
-> Bool -- ^ have we run Unarise yet?
-> String -- ^ who produced the STG?
-> [GenStgTopBinding a]
-> IO ()
-lintStgTopBindings logger dflags this_mod unarised whodunnit binds
+lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds
= {-# SCC "StgLint" #-}
case initL this_mod unarised opts top_level_binds (lint_binds binds) of
Nothing ->
@@ -89,7 +92,8 @@ lintStgTopBindings logger dflags this_mod unarised whodunnit binds
opts = initStgPprOpts dflags
-- Bring all top-level binds into scope because CoreToStg does not generate
-- bindings in dependency order (so we may see a use before its definition).
- top_level_binds = mkVarSet (bindersOfTopBinds binds)
+ top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))
+ (interactiveInScope ictxt)
lint_binds :: [GenStgTopBinding a] -> LintM ()
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
index c05450c0f761452f87ddadfc75ef66c75d88f4f1..d9f1342b6673df25597c41d55fc6d3fcce4a111e 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ b/compiler/GHC/Stg/Pipeline.hs
@@ -24,6 +24,7 @@ import GHC.Stg.Unarise ( unarise )
import GHC.Stg.CSE ( stgCse )
import GHC.Stg.Lift ( stgLiftLams )
import GHC.Unit.Module ( Module )
+import GHC.Runtime.Context ( InteractiveContext )
import GHC.Driver.Session
import GHC.Utils.Error
@@ -49,11 +50,11 @@ runStgM mask (StgM m) = evalStateT m mask
stg2stg :: Logger
-> DynFlags -- includes spec of what stg-to-stg passes to do
+ -> InteractiveContext
-> Module -- module being compiled
-> [StgTopBinding] -- input program
-> IO [StgTopBinding] -- output program
-
-stg2stg logger dflags this_mod binds
+stg2stg logger dflags ictxt this_mod binds
= do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
; showPass logger dflags "Stg2Stg"
-- Do the main business!
@@ -75,7 +76,7 @@ stg2stg logger dflags this_mod binds
where
stg_linter unarised
| gopt Opt_DoStgLinting dflags
- = lintStgTopBindings logger dflags this_mod unarised
+ = lintStgTopBindings logger dflags ictxt this_mod unarised
| otherwise
= \ _whodunnit _binds -> return ()
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 03ba9b5549c162085b7f4f9619227f1473de9f49..6e2107e9d6de8abf230e87fcd2d6b81b31d12bf9 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -58,7 +58,8 @@ module GHC.Stg.Syntax (
bindersOf, bindersOfTop, bindersOfTopBinds,
-- ppr
- StgPprOpts(..), initStgPprOpts, panicStgPprOpts,
+ StgPprOpts(..), initStgPprOpts,
+ panicStgPprOpts, shortStgPprOpts,
pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding,
pprGenStgTopBinding, pprStgTopBinding,
pprGenStgTopBindings, pprStgTopBindings
@@ -691,6 +692,13 @@ panicStgPprOpts = StgPprOpts
{ stgSccEnabled = True
}
+-- | STG pretty-printing options used for short messages
+shortStgPprOpts :: StgPprOpts
+shortStgPprOpts = StgPprOpts
+ { stgSccEnabled = False
+ }
+
+
pprGenStgTopBinding
:: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc
pprGenStgTopBinding opts b = case b of
@@ -778,9 +786,10 @@ pprStgExpr opts e = case e of
, hang (text "} in ") 2 (pprStgExpr opts expr)
]
- StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case
+ StgTick _tickish expr -> sdocOption sdocSuppressTicks $ \case
True -> pprStgExpr opts expr
- False -> sep [ ppr tickish, pprStgExpr opts expr ]
+ False -> pprStgExpr opts expr
+ -- XXX sep [ ppr tickish, pprStgExpr opts expr ]
-- Don't indent for a single case alternative.
StgCase expr bndr alt_type [alt]
diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/StgToByteCode.hs
similarity index 69%
rename from compiler/GHC/CoreToByteCode.hs
rename to compiler/GHC/StgToByteCode.hs
index dbb64d51d50c53ebd10e866d2dbc3926c0685418..e14de72eb5ca0db3a24d69fdc250445283ff9055 100644
--- a/compiler/GHC/CoreToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -10,8 +10,8 @@
-- (c) The University of Glasgow 2002-2006
--
--- | GHC.CoreToByteCode: Generate bytecode from Core
-module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
+-- | GHC.StgToByteCode: Generate bytecode from STG
+module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen, stgExprToBCOs ) where
#include "HsVersions.h"
@@ -24,6 +24,11 @@ import GHC.ByteCode.Instr
import GHC.ByteCode.Asm
import GHC.ByteCode.Types
+import GHC.Cmm.CallConv
+import GHC.Cmm.Expr
+import GHC.Cmm.Node
+import GHC.Cmm.Utils
+
import GHC.Platform
import GHC.Platform.Profile
@@ -36,12 +41,9 @@ import GHC.Types.Name
import GHC.Types.Id.Make
import GHC.Types.Id
import GHC.Types.ForeignCall
-import GHC.Core.Utils
import GHC.Core
-import GHC.Core.Ppr
import GHC.Types.Literal
import GHC.Builtin.PrimOps
-import GHC.Core.FVs
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.DataCon
@@ -55,6 +57,7 @@ import GHC.Core.TyCo.Ppr ( pprType )
import GHC.Utils.Error
import GHC.Types.Unique
import GHC.Builtin.Uniques
+import GHC.Builtin.Utils ( primOpId )
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
@@ -64,7 +67,6 @@ import GHC.Data.Bitmap
import GHC.Data.OrdList
import GHC.Data.Maybe
import GHC.Types.Var.Env
-import GHC.Builtin.Names ( unsafeEqualityProofName )
import GHC.Types.Tickish
import Data.List ( genericReplicate, genericLength, intersperse
@@ -89,35 +91,44 @@ import Data.Ord
import GHC.Stack.CCS
import Data.Either ( partitionEithers )
+import qualified GHC.Types.CostCentre as CC
+import GHC.Stg.Syntax
+import GHC.Stg.FVs
+
-- -----------------------------------------------------------------------------
-- Generating byte code for a complete module
byteCodeGen :: HscEnv
-> Module
- -> CoreProgram
+ -> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
= withTiming logger dflags
- (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))
+ (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
(const ()) $ do
-- Split top-level binds into strings and others.
-- See Note [generating code for top-level string literal bindings].
- let (strings, flatBinds) = partitionEithers $ do -- list monad
- (bndr, rhs) <- flattenBinds binds
- return $ case exprIsTickedString_maybe rhs of
- Just str -> Left (bndr, str)
- _ -> Right (bndr, simpleFreeVars rhs)
+ let (strings, lifted_binds) = partitionEithers $ do -- list monad
+ bnd <- binds
+ case bnd of
+ StgTopLifted bnd -> [Right bnd]
+ StgTopStringLit b str -> [Left (b, str)]
+ flattenBind (StgNonRec b e) = [(b,e)]
+ flattenBind (StgRec bs) = bs
stringPtrs <- allocateTopStrings hsc_env strings
us <- mkSplitUniqSupply 'y'
(BcM_State{..}, proto_bcos) <-
- runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
- mapM schemeTopBind flatBinds
+ runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
+ prepd_binds <- mapM bcPrepBind lifted_binds
+ let flattened_binds =
+ concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)
+ mapM schemeTopBind flattened_binds
when (notNull ffis)
- (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?")
+ (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn logger dflags Opt_D_dump_BCOs
"Proto-BCOs" FormatByteCode
@@ -168,27 +179,30 @@ literals:
-- Generating byte code for an expression
-- Returns: the root BCO for this expression
-coreExprToBCOs :: HscEnv
- -> Module
- -> CoreExpr
- -> IO UnlinkedBCO
-coreExprToBCOs hsc_env this_mod expr
+stgExprToBCOs :: HscEnv
+ -> Module
+ -> Type
+ -> StgRhs
+ -> IO UnlinkedBCO
+stgExprToBCOs hsc_env this_mod expr_ty expr
= withTiming logger dflags
- (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))
+ (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))
(const ()) $ do
- -- create a totally bogus name for the top-level BCO; this
- -- should be harmless, since it's never used for anything
- let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
-- the uniques are needed to generate fresh variables when we introduce new
-- let bindings for ticked expressions
us <- mkSplitUniqSupply 'y'
(BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
- <- runBc hsc_env us this_mod Nothing emptyVarEnv $
- schemeR [] (invented_name, simpleFreeVars expr)
+ <- runBc hsc_env us this_mod Nothing emptyVarEnv $ do
+ prepd_expr <- annBindingFreeVars <$>
+ bcPrepBind (StgNonRec dummy_id expr)
+ case prepd_expr of
+ (StgNonRec _ cg_expr) -> schemeR [] (idName dummy_id, cg_expr)
+ _ ->
+ panic "GHC.StgByteCode.stgExprToBCOs"
when (notNull mallocd)
- (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?")
+ (panic "GHC.StgToByteCode.stgExprToBCOs: missing final emitBc?")
dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode
(ppr proto_bco)
@@ -196,27 +210,110 @@ coreExprToBCOs hsc_env this_mod expr
assembleOneBCO hsc_env proto_bco
where dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
-
--- The regular freeVars function gives more information than is useful to
--- us here. We need only the free variables, not everything in an FVAnn.
--- Historical note: At one point FVAnn was more sophisticated than just
--- a set. Now it isn't. So this function is much simpler. Keeping it around
--- so that if someone changes FVAnn, they will get a nice type error right
--- here.
-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
-simpleFreeVars = freeVars
+ -- we need an otherwise unused Id for bytecode generation
+ dummy_id = mkSysLocal (fsLit "BCO_toplevel")
+ (mkPseudoUniqueE 0)
+ Many
+ expr_ty
+{-
+ Prepare the STG for bytecode generation:
+
+ - Ensure that all breakpoints are directly under
+ a let-binding, introducing a new binding for
+ those that aren't already.
+
+ - Protect Not-necessarily lifted join points, see
+ Note [Not-necessarily-lifted join points]
+
+ -}
+
+bcPrepRHS :: StgRhs -> BcM StgRhs
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
+ {- If we have a breakpoint directly under an StgRhsClosure we don't
+ need to introduce a new binding for it.
+ -}
+ expr' <- bcPrepExpr expr
+ pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
+bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
+ StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
+bcPrepRHS con@StgRhsCon{} = pure con
+
+bcPrepExpr :: StgExpr -> BcM StgExpr
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
+ | isLiftedTypeKind (typeKind tick_ty) = do
+ id <- newId tick_ty
+ rhs' <- bcPrepExpr rhs
+ let expr' = StgTick bp rhs'
+ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
+ CC.dontCareCCS
+ ReEntrant
+ []
+ expr'
+ )
+ letExp = StgLet noExtFieldSilent bnd (StgApp id [])
+ pure letExp
+ | otherwise = do
+ id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)
+ st <- newId realWorldStatePrimTy
+ rhs' <- bcPrepExpr rhs
+ let expr' = StgTick bp rhs'
+ bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
+ CC.dontCareCCS
+ ReEntrant
+ [voidArgId]
+ expr'
+ )
+ pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])
+bcPrepExpr (StgTick tick rhs) =
+ StgTick tick <$> bcPrepExpr rhs
+bcPrepExpr (StgLet xlet bnds expr) =
+ StgLet xlet <$> bcPrepBind bnds
+ <*> bcPrepExpr expr
+bcPrepExpr (StgLetNoEscape xlne bnds expr) =
+ StgLet xlne <$> bcPrepBind bnds
+ <*> bcPrepExpr expr
+bcPrepExpr (StgCase expr bndr alt_type alts) =
+ StgCase <$> bcPrepExpr expr
+ <*> pure bndr
+ <*> pure alt_type
+ <*> mapM bcPrepAlt alts
+bcPrepExpr lit@StgLit{} = pure lit
+-- See Note [Not-necessarily-lifted join points], step 3.
+bcPrepExpr (StgApp x [])
+ | isNNLJoinPoint x = pure $
+ StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
+bcPrepExpr app@StgApp{} = pure app
+bcPrepExpr app@StgConApp{} = pure app
+bcPrepExpr app@StgOpApp{} = pure app
+
+bcPrepAlt :: StgAlt -> BcM StgAlt
+bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr
+
+bcPrepBind :: StgBinding -> BcM StgBinding
+-- explicitly match all constructors so we get a warning if we miss any
+bcPrepBind (StgNonRec bndr rhs) =
+ let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
+ in StgNonRec bndr' <$> bcPrepRHS rhs'
+bcPrepBind (StgRec bnds) =
+ StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
+ bnds
+
+bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
+-- See Note [Not-necessarily-lifted join points], step 2.
+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
+ | isNNLJoinPoint x
+ = ( protectNNLJoinPointId x
+ , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
+bcPrepSingleBind bnd = bnd
-- -----------------------------------------------------------------------------
-- Compilation schema for the bytecode generator
type BCInstrList = OrdList BCInstr
-newtype ByteOff = ByteOff Int
- deriving (Enum, Eq, Integral, Num, Ord, Real)
-
-newtype WordOff = WordOff Int
- deriving (Enum, Eq, Integral, Num, Ord, Real)
-
wordsToBytes :: Platform -> WordOff -> ByteOff
wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral
@@ -226,7 +323,7 @@ bytesToWords platform (ByteOff bytes) =
let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
in if r == 0
then fromIntegral q
- else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes
+ else panic $ "GHC.StgToByteCode.bytesToWords: bytes=" ++ show bytes
wordSize :: Platform -> ByteOff
wordSize platform = ByteOff (platformWordSizeInBytes platform)
@@ -246,7 +343,7 @@ ppBCEnv p
$$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
$$ text "end-env"
where
- pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
+ pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
cmp_snd x y = compare (snd x) (snd y)
-}
@@ -256,7 +353,7 @@ mkProtoBCO
:: Platform
-> name
-> BCInstrList
- -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
+ -> Either [CgStgAlt] (CgStgRhs)
-- ^ original expression; for debugging only
-> Int
-> Word16
@@ -315,12 +412,17 @@ argBits platform (rep : args)
| isFollowableArg rep = False : argBits platform args
| otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
+non_void :: [ArgRep] -> [ArgRep]
+non_void = filter nv
+ where nv V = False
+ nv _ = True
+
-- -----------------------------------------------------------------------------
-- schemeTopBind
-- Compile code for the right-hand side of a top-level binding
-schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
+schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
schemeTopBind (id, rhs)
| Just data_con <- isDataConWorkId_maybe id,
isNullaryRepDataCon data_con = do
@@ -351,44 +453,27 @@ schemeTopBind (id, rhs)
-- Park the resulting BCO in the monad. Also requires the
-- name of the variable to which this value was bound,
-- so as to give the resulting BCO a name.
-
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.
- -> (Name, AnnExpr Id DVarSet)
+ -> (Name, CgStgRhs)
-> BcM (ProtoBCO Name)
schemeR fvs (nm, rhs)
-{-
- | trace (showSDoc (
- (char ' '
- $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
- $$ pprCoreExpr (deAnnotate rhs)
- $$ char ' '
- ))) False
- = undefined
- | otherwise
--}
= schemeR_wrk fvs nm rhs (collect rhs)
-- If an expression is a lambda (after apply bcView), return the
-- list of arguments to the lambda (in R-to-L order) and the
-- underlying expression
-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
-collect (_, e) = go [] e
- where
- go xs e | Just e' <- bcView e = go xs e'
- go xs (AnnLam x (_,e))
- | typePrimRep (idType x) `lengthExceeds` 1
- = multiValException
- | otherwise
- = go (x:xs) e
- go xs not_lambda = (reverse xs, not_lambda)
+
+collect :: CgStgRhs -> ([Var], CgStgExpr)
+collect (StgRhsClosure _ _ _ args body) = (args, body)
+collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])
schemeR_wrk
:: [Id]
-> Name
- -> AnnExpr Id DVarSet -- expression e, for debugging only
- -> ([Var], AnnExpr' Var DVarSet) -- result of collect on e
+ -> CgStgRhs -- expression e, for debugging only
+ -> ([Var], CgStgExpr) -- result of collect on e
-> BcM (ProtoBCO Name)
schemeR_wrk fvs nm original_body (args, body)
= do
@@ -417,17 +502,16 @@ schemeR_wrk fvs nm original_body (args, body)
arity bitmap_size bitmap False{-not alts-})
-- introduce break instructions for ticked expressions
-schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-schemeER_wrk d p rhs
- | AnnTick (Breakpoint _ext tick_no fvs) (_annot, newRhs) <- rhs
- = do code <- schemeE d 0 p newRhs
+schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
+schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
+ = do code <- schemeE d 0 p rhs
cc_arr <- getCCArray
this_mod <- moduleName <$> getCurrentModule
platform <- profilePlatform <$> getProfile
let idOffSets = getVarOffSets platform d p fvs
let breakInfo = CgBreakInfo
{ cgb_vars = idOffSets
- , cgb_resty = exprType (deAnnotate' newRhs)
+ , cgb_resty = tick_ty
}
newBreakInfo tick_no breakInfo
hsc_env <- getHscEnv
@@ -437,7 +521,7 @@ schemeER_wrk d p rhs
| otherwise = toRemotePtr nullPtr
let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
return $ breakInstr `consOL` code
- | otherwise = schemeE d 0 p rhs
+schemeER_wrk d p rhs = schemeE d 0 p rhs
getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
getVarOffSets platform depth env = map getOffSet
@@ -469,7 +553,7 @@ trunc16B = truncIntegral16
trunc16W :: WordOff -> Word16
trunc16W = truncIntegral16
-fvsToEnv :: BCEnv -> DVarSet -> [Id]
+fvsToEnv :: BCEnv -> CgStgRhs -> [Id]
-- 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
@@ -478,93 +562,128 @@ fvsToEnv :: BCEnv -> DVarSet -> [Id]
--
-- The code that constructs the thunk, and the code that executes
-- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
- isId v, -- Could be a type variable
- v `Map.member` p]
+
+fvsToEnv p (StgRhsClosure fvs _ _ _ _) =
+ [v | v <- dVarSetElems fvs,
+ v `Map.member` p]
+fvsToEnv _ _ = []
-- -----------------------------------------------------------------------------
-- schemeE
+-- Returning an unlifted value.
+-- Heave it on the stack, SLIDE, and RETURN.
returnUnboxedAtom
:: StackDepth
-> Sequel
-> BCEnv
- -> AnnExpr' Id DVarSet
- -> ArgRep
+ -> StgArg
-> BcM BCInstrList
--- Returning an unlifted value.
--- Heave it on the stack, SLIDE, and RETURN.
-returnUnboxedAtom d s p e e_rep = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+returnUnboxedAtom d s p e = do
+ let reps = case e of
+ StgLitArg lit -> typePrimRepArgs (literalType lit)
+ StgVarArg i -> bcIdPrimReps i
(push, szb) <- pushAtom d p e
- return (push -- value onto stack
- `appOL` mkSlideB platform szb (d - s) -- clear to sequel
- `snocOL` RETURN_UBX e_rep) -- go
+ ret <- returnUnboxedReps d s szb reps
+ return (push `appOL` ret)
+
+-- return an unboxed value from the top of the stack
+returnUnboxedReps
+ :: StackDepth
+ -> Sequel
+ -> ByteOff -- size of the thing we're returning
+ -> [PrimRep] -- representations
+ -> BcM BCInstrList
+returnUnboxedReps d s szb reps = do
+ profile <- getProfile
+ let platform = profilePlatform profile
+ non_void VoidRep = False
+ non_void _ = True
+ ret <- case filter non_void reps of
+ -- use RETURN_UBX for unary representations
+ [] -> return (unitOL $ RETURN_UBX V)
+ [rep] -> return (unitOL $ RETURN_UBX (toArgRep platform rep))
+ -- otherwise use RETURN_TUPLE with a tuple descriptor
+ nv_reps -> do
+ let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps
+ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets
+ tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
+ return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL`
+ PUSH_BCO tuple_bco `consOL`
+ unitOL RETURN_TUPLE
+ return ( mkSlideB platform szb (d - s) -- clear to sequel
+ `appOL` ret) -- go
+
+-- construct and return an unboxed tuple
+returnUnboxedTuple
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> [StgArg]
+ -> BcM BCInstrList
+returnUnboxedTuple d s p es = do
+ profile <- getProfile
+ let platform = profilePlatform profile
+ arg_ty e = primRepCmmType platform (atomPrimRep e)
+ (tuple_info, tuple_components) = layoutTuple profile d arg_ty es
+ go _ pushes [] = return (reverse pushes)
+ go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
+ MASSERT(off == dd + szb)
+ go (dd + szb) (push:pushes) cs
+ pushes <- go d [] tuple_components
+ ret <- returnUnboxedReps d
+ s
+ (wordsToBytes platform $ tupleSize tuple_info)
+ (map atomPrimRep es)
+ return (mconcat pushes `appOL` ret)
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
schemeE
- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-schemeE d s p e
- | Just e' <- bcView e
- = schemeE d s p e'
-
+ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
+schemeE d s p (StgLit lit) = returnUnboxedAtom d s p (StgLitArg lit)
+schemeE d s p (StgApp x [])
+ | isUnliftedType (idType x) = returnUnboxedAtom d s p (StgVarArg x)
-- Delegate tail-calls to schemeT.
-schemeE d s p e@(AnnApp _ _) = schemeT d s p e
-
-schemeE d s p e@(AnnLit lit) = do
- platform <- profilePlatform <$> getProfile
- returnUnboxedAtom d s p e (typeArgRep platform (literalType lit))
-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
-
-schemeE d s p e@(AnnVar v)
- -- See Note [Not-necessarily-lifted join points], step 3.
- | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
- | isUnliftedType (idType v) = do
- platform <- profilePlatform <$> getProfile
- returnUnboxedAtom d s p e (bcIdArgRep platform v)
- | otherwise = schemeT d s p e
-
-schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
- | (AnnVar v, args_r_to_l) <- splitApp rhs,
- Just data_con <- isDataConWorkId_maybe v,
- dataConRepArity data_con == length args_r_to_l
+schemeE d s p e@(StgApp {}) = schemeT d s p e
+schemeE d s p e@(StgConApp {}) = schemeT d s p e
+schemeE d s p e@(StgOpApp {}) = schemeT d s p e
+schemeE d s p (StgLetNoEscape xlet bnd body)
+ = schemeE d s p (StgLet xlet bnd body)
+schemeE d s p (StgLet _xlet
+ (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))
+ body)
= do -- Special case for a non-recursive let whose RHS is a
-- saturated constructor application.
-- Just allocate the constructor and carry on
- alloc_code <- mkConAppCode d s p data_con args_r_to_l
+ alloc_code <- mkConAppCode d s p data_con args
platform <- targetPlatform <$> getDynFlags
let !d2 = d + wordSize platform
body_code <- schemeE d2 s (Map.insert x d2 p) body
return (alloc_code `appOL` body_code)
-
-- General case for let. Generates correct, if inefficient, code in
-- all situations.
-schemeE d s p (AnnLet binds (_,body)) = do
+schemeE d s p (StgLet _ext binds body) = do
platform <- targetPlatform <$> getDynFlags
- let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
- AnnRec xs_n_rhss -> unzip xs_n_rhss
+ let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
+ StgRec xs_n_rhss -> unzip xs_n_rhss
n_binds = genericLength xs
- fvss = map (fvsToEnv p' . fst) rhss
-
- -- See Note [Not-necessarily-lifted join points], step 2.
- (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss
+ fvss = map (fvsToEnv p') rhss
-- Sizes of free vars
size_w = trunc16W . idSizeW platform
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss'
+ arities = map (genericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
-- after the closures have been allocated in the heap (but not
-- filled in), and pointers to them parked on the stack.
offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))
- p' = Map.insertList (zipE xs' offsets) p
+ p' = Map.insertList (zipE xs offsets) p
d' = d + wordsToBytes platform n_binds
zipE = zipEqual "schemeE"
@@ -583,7 +702,7 @@ schemeE d s p (AnnLet binds (_,body)) = do
mkap | arity == 0 = MKAP
| otherwise = MKPAP
build_thunk dd (fv:fvs) size bco off arity = do
- (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
+ (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv)
more_push_code <-
build_thunk (dd + pushed_szb) fvs size bco off arity
return (push_code `appOL` more_push_code)
@@ -595,112 +714,35 @@ schemeE d s p (AnnLet binds (_,body)) = do
mkAlloc sz arity = ALLOC_PAP arity sz
is_tick = case binds of
- AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
+ StgNonRec id _ -> occNameFS (getOccName id) == tickFS
_other -> False
- compile_bind d' fvs x rhs size arity off = do
+ compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do
bco <- schemeR fvs (getName x,rhs)
build_thunk d' fvs size bco off arity
compile_binds =
[ compile_bind d' fvs x rhs size arity (trunc16W n)
| (fvs, x, rhs, size, arity, n) <-
- zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]
+ zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
]
body_code <- schemeE d' s p' body
thunk_codes <- sequence compile_binds
return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
--- Introduce a let binding for a ticked case expression. This rule
--- *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
-schemeE d s p exp@(AnnTick (Breakpoint _ext _id _fvs) _rhs)
- | 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
- -- let f = \s . tick<n> e
- -- 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.
- --
- -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where
- -- 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.
-
- id <- newId (mkVisFunTyMany realWorldStatePrimTy ty)
- st <- newId realWorldStatePrimTy
- let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
- (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
- (emptyDVarSet, AnnVar realWorldPrimId)))
- schemeE d s p letExp
-
- where
- exp' = deAnnotate' exp
- fvs = exprFreeVarsDSet exp'
- ty = exprType exp'
+schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
+ = panic ("schemeE: Breakpoint without let binding: " ++
+ show bp_id ++
+ " forgot to run bcPrep?")
-- ignore other kinds of tick
-schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
+schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
-- no alts: scrut is guaranteed to diverge
-schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-
--- handle pairs with one void argument (e.g. state token)
-schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1, bind2] rhs])
- | isUnboxedTupleDataCon dc
- -- Convert
- -- case .... of x { (# V'd-thing, a #) -> ... }
- -- to
- -- case .... of a { DEFAULT -> ... }
- -- because the return convention for both are identical.
- --
- -- 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.
- , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
- ([], [_])
- -> Just $ doCase d s p scrut bind2 [AnnAlt DEFAULT [] rhs] (Just bndr)
- ([_], [])
- -> Just $ doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr)
- _ -> Nothing
- = res
-
--- handle unit tuples
-schemeE d s p (AnnCase scrut bndr _ [AnnAlt (DataAlt dc) [bind1] rhs])
- | isUnboxedTupleDataCon dc
- , typePrimRep (idType bndr) `lengthAtMost` 1
- = doCase d s p scrut bind1 [AnnAlt DEFAULT [] rhs] (Just bndr)
-
--- handle nullary tuples
-schemeE d s p (AnnCase scrut bndr _ alt@[AnnAlt DEFAULT [] _])
- | isUnboxedTupleType (idType bndr)
- , Just ty <- case typePrimRep (idType bndr) of
- [_] -> Just (unwrapType (idType bndr))
- [] -> Just unboxedUnitTy
- _ -> Nothing
- -- 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)
-
-schemeE d s p (AnnCase scrut bndr _ alts)
- = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
-
-schemeE _ _ _ expr
- = pprPanic "GHC.CoreToByteCode.schemeE: unhandled case"
- (pprCoreExpr (deAnnotate' expr))
+schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
+
+schemeE d s p (StgCase scrut bndr _ alts)
+ = doCase d s p scrut bndr alts
-- Is this Id a not-necessarily-lifted join point?
-- See Note [Not-necessarily-lifted join points], step 1
@@ -708,16 +750,6 @@ isNNLJoinPoint :: Id -> Bool
isNNLJoinPoint x = isJoinId x &&
Just True /= isLiftedType_maybe (idType x)
--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
--- See Note [Not-necessarily-lifted join points], step 2.
-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)
-protectNNLJoinPointBind x rhs@(fvs, _)
- | isNNLJoinPoint x
- = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))
-
- | otherwise
- = (x, rhs)
-
-- Update an Id's type to take a Void# argument.
-- Precondition: the Id is a not-necessarily-lifted join point.
-- See Note [Not-necessarily-lifted join points]
@@ -763,7 +795,7 @@ isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:
type to tack on a `(# #) ->`.
Note that functions are never levity-polymorphic, so this transformation
changes an NNLJP to a non-levity-polymorphic join point. This is done
- in protectNNLJoinPointBind, called from the AnnLet case of schemeE.
+ in bcPrepSingleBind.
3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
being careful to note the new type of the NNLJP. This is done in the AnnVar
@@ -805,10 +837,8 @@ Right Fix is to take advantage of join points as goto-labels.
--
-- 1. The fn denotes a ccall. Defer to generateCCall.
--
--- 2. (Another nasty hack). Spot (# a::V, b #) and treat
--- it simply as b -- since the representations are identical
--- (the V takes up zero stack space). Also, spot
--- (# b #) and treat it as b.
+-- 2. An unboxed tuple: push the components on the top of
+-- the stack and return.
--
-- 3. Application of a constructor, by defn saturated.
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
@@ -820,59 +850,45 @@ Right Fix is to take advantage of join points as goto-labels.
schemeT :: StackDepth -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
- -> AnnExpr' Id DVarSet
+ -> CgStgExpr
-> BcM BCInstrList
-schemeT d s p app
-
-- Case 0
+schemeT d s p app
| Just (arg, constr_names) <- maybe_is_tagToEnum_call app
= implement_tagToId d s p arg constr_names
-- Case 1
- | Just (CCall ccall_spec) <- isFCallId_maybe fn
+schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
= if isSupportedCConv ccall_spec
- then generateCCall d s p ccall_spec fn args_r_to_l
+ then generateCCall d s p ccall_spec result_ty (reverse args)
else unsupportedCConvException
+schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
+ = doTailCall d s p (primOpId op) (reverse args)
- -- Case 2: Constructor application
- | Just con <- maybe_saturated_dcon
- , isUnboxedTupleDataCon con
- = do
- platform <- profilePlatform <$> getProfile
- case args_r_to_l of
- [arg1,arg2] | isVAtom platform arg1 ->
- unboxedTupleReturn d s p arg2
- [arg1,arg2] | isVAtom platform arg2 ->
- unboxedTupleReturn d s p arg1
- _other -> multiValException
+schemeT _d _s _p (StgOpApp StgPrimCallOp{} _args _ty)
+ = unsupportedCConvException
+
+ -- Case 2: Unboxed tuple
+schemeT d s p (StgConApp con _ext args _tys)
+ | isUnboxedTupleDataCon con || isUnboxedSumDataCon con
+ = returnUnboxedTuple d s p args
-- Case 3: Ordinary data constructor
- | Just con <- maybe_saturated_dcon
- = do alloc_con <- mkConAppCode d s p con args_r_to_l
+ | otherwise
+ = do alloc_con <- mkConAppCode d s p con args
platform <- profilePlatform <$> getProfile
return (alloc_con `appOL`
mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
ENTER)
-- Case 4: Tail call of function
- | otherwise
- = doTailCall d s p fn args_r_to_l
-
- where
- -- Extract the args (R->L) and fn
- -- The function will necessarily be a variable,
- -- because we are compiling a tail call
- (AnnVar fn, args_r_to_l) = splitApp app
-
- -- Only consider this to be a constructor application iff it is
- -- saturated. Otherwise, we'll call the constructor wrapper.
- n_args = length args_r_to_l
- maybe_saturated_dcon
- = case isDataConWorkId_maybe fn of
- Just con | dataConRepArity con == n_args -> Just con
- _ -> Nothing
+schemeT d s p (StgApp fn args)
+ = doTailCall d s p fn (reverse args)
+
+schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT"
+ (pprStgExpr shortStgPprOpts e)
-- -----------------------------------------------------------------------------
-- Generate code to build a constructor application,
@@ -883,26 +899,17 @@ mkConAppCode
-> Sequel
-> BCEnv
-> DataCon -- The data constructor
- -> [AnnExpr' Id DVarSet] -- Args, in *reverse* order
+ -> [StgArg] -- Args, in *reverse* order
-> BcM BCInstrList
-mkConAppCode _ _ _ con [] -- Nullary constructor
- = ASSERT( isNullaryRepDataCon con )
- return (unitOL (PUSH_G (getName (dataConWorkId con))))
- -- Instead of doing a PACK, which would allocate a fresh
- -- copy of this constructor, use the single shared version.
-
-mkConAppCode orig_d _ p con args_r_to_l =
- ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
+mkConAppCode orig_d _ p con args = app_code
where
app_code = do
profile <- getProfile
let platform = profilePlatform profile
- -- The args are initially in reverse order, but mkVirtHeapOffsets
- -- expects them to be left-to-right.
- let non_voids =
+ non_voids =
[ NonVoid (prim_rep, arg)
- | arg <- reverse args_r_to_l
+ | arg <- args
, let prim_rep = atomPrimRep arg
, not (isVoidRep prim_rep)
]
@@ -922,20 +929,6 @@ mkConAppCode orig_d _ p con args_r_to_l =
-- Push on the stack in the reverse order.
do_pushery orig_d (reverse args_offsets)
-
--- -----------------------------------------------------------------------------
--- Returning an unboxed tuple with one non-void component (the only
--- case we can handle).
---
--- Remember, we don't want to *evaluate* the component that is being
--- returned, even if it is a pointed type. We always just return.
-
-unboxedTupleReturn
- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-unboxedTupleReturn d s p arg = do
- platform <- profilePlatform <$> getProfile
- returnUnboxedAtom d s p arg (atomRep platform arg)
-
-- -----------------------------------------------------------------------------
-- Generate code for a tail-call
@@ -944,7 +937,7 @@ doTailCall
-> Sequel
-> BCEnv
-> Id
- -> [AnnExpr' Id DVarSet]
+ -> [StgArg]
-> BcM BCInstrList
doTailCall init_d s p fn args = do
platform <- profilePlatform <$> getProfile
@@ -952,7 +945,7 @@ doTailCall init_d s p fn args = do
where
do_pushes !d [] reps = do
ASSERT( null reps ) return ()
- (push_fn, sz) <- pushAtom d p (AnnVar fn)
+ (push_fn, sz) <- pushAtom d p (StgVarArg fn)
platform <- profilePlatform <$> getProfile
ASSERT( sz == wordSize platform ) return ()
let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
@@ -997,7 +990,7 @@ findPushSeq (D: rest)
findPushSeq (L: rest)
= (PUSH_APPLY_L, 1, rest)
findPushSeq _
- = panic "GHC.CoreToByteCode.findPushSeq"
+ = panic "GHC.StgToByteCode.findPushSeq"
-- -----------------------------------------------------------------------------
-- Case expressions
@@ -1006,23 +999,31 @@ doCase
:: StackDepth
-> Sequel
-> BCEnv
- -> AnnExpr Id DVarSet
+ -> CgStgExpr
-> Id
- -> [AnnAlt Id DVarSet]
- -> Maybe Id -- Just x <=> is an unboxed tuple case with scrut binder,
- -- don't enter the result
+ -> [CgStgAlt]
-> BcM BCInstrList
-doCase d s p (_,scrut) bndr alts is_unboxed_tuple
- | typePrimRep (idType bndr) `lengthExceeds` 1
- = multiValException
-
- | otherwise
+doCase d s p scrut bndr alts
= do
profile <- getProfile
hsc_env <- getHscEnv
let
platform = profilePlatform profile
+ -- Are we dealing with an unboxed tuple with a tuple return frame?
+ --
+ -- 'Simple' tuples with at most one non-void component,
+ -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
+ -- tuple return frame. This is because (# foo #) and (# foo, Void# #)
+ -- have the same runtime rep. We have more efficient specialized
+ -- return frames for the situations with one non-void element.
+
+ ubx_tuple_frame =
+ (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
+ length non_void_arg_reps > 1
+
+ non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
+
profiling
| Just interp <- hsc_interp hsc_env
= interpreterProfiled interp
@@ -1033,53 +1034,84 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- When an alt is entered, it assumes the returned value is
-- on top of the itbl.
ret_frame_size_b :: StackDepth
- ret_frame_size_b = 2 * wordSize platform
+ ret_frame_size_b | ubx_tuple_frame =
+ (if profiling then 5 else 4) * wordSize platform
+ | otherwise = 2 * wordSize platform
- -- The extra frame we push to save/restore the CCCS when profiling
- save_ccs_size_b | profiling = 2 * wordSize platform
+ -- The stack space used to save/restore the CCCS when profiling
+ save_ccs_size_b | profiling &&
+ not ubx_tuple_frame = 2 * wordSize platform
| otherwise = 0
-- An unlifted value gets an extra info table pushed on top
-- when it is returned.
unlifted_itbl_size_b :: StackDepth
- unlifted_itbl_size_b | isAlgCase = 0
- | otherwise = wordSize platform
+ unlifted_itbl_size_b | isAlgCase = 0
+ | ubx_tuple_frame = 3 * wordSize platform
+ | otherwise = wordSize platform
+
+ (bndr_size, tuple_info, args_offsets)
+ | ubx_tuple_frame =
+ let bndr_ty = primRepCmmType platform
+ bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)
+ (tuple_info, args_offsets) =
+ layoutTuple profile 0 bndr_ty bndr_reps
+ in ( wordsToBytes platform (tupleSize tuple_info)
+ , tuple_info
+ , args_offsets
+ )
+ | otherwise = ( wordsToBytes platform (idSizeW platform bndr)
+ , voidTupleInfo
+ , []
+ )
-- depth of stack after the return value has been pushed
d_bndr =
- d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)
+ d + ret_frame_size_b + bndr_size
-- depth of stack after the extra info table for an unboxed return
-- has been pushed, if any. This is the stack depth at the
-- continuation.
- d_alts = d_bndr + unlifted_itbl_size_b
+ d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
-- Env in which to compile the alts, not including
-- any vars bound by the alts themselves
- p_alts0 = Map.insert bndr d_bndr p
-
- p_alts = case is_unboxed_tuple of
- Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
- Nothing -> p_alts0
+ p_alts = Map.insert bndr d_bndr p
bndr_ty = idType bndr
- isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
+ isAlgCase = not (isUnliftedType bndr_ty)
-- given an alt, return a discr and code for it.
- codeAlt (AnnAlt DEFAULT _ (_,rhs))
+ codeAlt (DEFAULT, _, rhs)
= do rhs_code <- schemeE d_alts s p_alts rhs
return (NoDiscr, rhs_code)
- codeAlt alt@(AnnAlt _ bndrs (_,rhs))
+ codeAlt alt@(_, bndrs, rhs)
-- primitive or nullary constructor alt: no need to UNPACK
| null real_bndrs = do
rhs_code <- schemeE d_alts s p_alts rhs
return (my_discr alt, rhs_code)
- -- If an alt attempts to match on an unboxed tuple or sum, we must
- -- bail out, as the bytecode compiler can't handle them.
- -- (See #14608.)
- | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
- = multiValException
+ | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
+ let bndr_ty = primRepCmmType platform . bcIdPrimRep
+ tuple_start = d_bndr
+ (tuple_info, args_offsets) =
+ layoutTuple profile
+ 0
+ bndr_ty
+ bndrs
+
+ stack_bot = d_alts
+
+ p' = Map.insertList
+ [ (arg, tuple_start -
+ wordsToBytes platform (tupleSize tuple_info) +
+ offset)
+ | (arg, offset) <- args_offsets
+ , not (isVoidRep $ bcIdPrimRep arg)]
+ p_alts
+ in do
+ rhs_code <- schemeE stack_bot s p' rhs
+ return (NoDiscr, rhs_code)
-- algebraic alt with some binders
| otherwise =
let (tot_wds, _ptrs_wds, args_offsets) =
@@ -1104,24 +1136,24 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
where
real_bndrs = filterOut isTyVar bndrs
- my_discr (AnnAlt DEFAULT _ _) = NoDiscr {-shouldn't really happen-}
- my_discr (AnnAlt (DataAlt dc) _ _)
+ my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
+ my_discr (DataAlt dc, _, _)
| isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
- = multiValException
+ = NoDiscr
| otherwise
= DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
- my_discr (AnnAlt (LitAlt l) _ _)
+ my_discr (LitAlt l, _, _)
= case l of LitNumber LitNumInt i -> DiscrI (fromInteger i)
LitNumber LitNumWord w -> DiscrW (fromInteger w)
LitFloat r -> DiscrF (fromRational r)
LitDouble r -> DiscrD (fromRational r)
LitChar i -> DiscrI (ord i)
- _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+ _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
maybe_ncons
| not isAlgCase = Nothing
| otherwise
- = case [dc | AnnAlt (DataAlt dc) _ _ <- alts] of
+ = case [dc | (DataAlt dc, _, _) <- alts] of
[] -> Nothing
(dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
@@ -1139,20 +1171,36 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- really want a bitmap up to depth (d-s). This affects compilation of
-- case-of-case expressions, which is the only time we can be compiling a
-- case expression with s /= 0.
- bitmap_size = trunc16W $ bytesToWords platform (d - s)
+
+ -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
+ (extra_pointers, extra_slots)
+ | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS
+ | ubx_tuple_frame = ([1], 2) -- tuple_info, tuple_BCO
+ | otherwise = ([], 0)
+
+ bitmap_size = trunc16W $ fromIntegral extra_slots +
+ bytesToWords platform (d - s)
+
bitmap_size' :: Int
bitmap_size' = fromIntegral bitmap_size
- bitmap = intsToReverseBitmap platform bitmap_size'{-size-}
- (sort (filter (< bitmap_size') rel_slots))
+
+
+ pointers =
+ extra_pointers ++
+ sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))
where
binds = Map.toList p
-- NB: unboxed tuple cases bind the scrut binder to the same offset
-- as one of the alt binders, so we have to remove any duplicates here:
rel_slots = nub $ map fromIntegral $ concatMap spread binds
- spread (id, offset) | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
- | otherwise = []
+ spread (id, offset) | isUnboxedTupleType (idType id) ||
+ isUnboxedSumType (idType id) = []
+ | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
+ | otherwise = []
where rel_offset = trunc16W $ bytesToWords platform (d - offset)
+ bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers
+
alt_stuff <- mapM codeAlt alts
alt_final <- mkMultiBranch maybe_ncons alt_stuff
@@ -1160,19 +1208,217 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
alt_bco_name = getName bndr
alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)
0{-no arity-} bitmap_size bitmap True{-is alts-}
--- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
--- "\n bitmap = " ++ show bitmap) $ do
-
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
p scrut
alt_bco' <- emitBc alt_bco
- let push_alts
- | isAlgCase = PUSH_ALTS alt_bco'
- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)
- return (push_alts `consOL` scrut_code)
+ if ubx_tuple_frame
+ then do
+ let args_ptrs =
+ map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))
+ args_offsets
+ tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
+ return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco
+ `consOL` scrut_code)
+ else let push_alts
+ | isAlgCase
+ = PUSH_ALTS alt_bco'
+ | otherwise
+ = let unlifted_rep =
+ case non_void_arg_reps of
+ [] -> V
+ [rep] -> rep
+ _ -> panic "schemeE(StgCase).push_alts"
+ in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
+ in return (push_alts `consOL` scrut_code)
+-- -----------------------------------------------------------------------------
+-- Deal with tuples
+
+-- The native calling convention uses registers for tuples, but in the
+-- bytecode interpreter, all values live on the stack.
+
+layoutTuple :: Profile
+ -> ByteOff
+ -> (a -> CmmType)
+ -> [a]
+ -> ( TupleInfo -- See Note [GHCi TupleInfo]
+ , [(a, ByteOff)] -- argument, offset on stack
+ )
+layoutTuple profile start_off arg_ty reps =
+ let platform = profilePlatform profile
+ (orig_stk_bytes, pos) = assignArgumentsPos profile
+ 0
+ NativeReturn
+ arg_ty
+ reps
+
+ -- keep the stack parameters in the same place
+ orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]
+
+ -- sort the register parameters by register and add them to the stack
+ (regs, reg_params)
+ = unzip $ sortBy (comparing fst)
+ [(reg, x) | (x, RegisterParam reg) <- pos]
+
+ (new_stk_bytes, new_stk_params) = assignStack platform
+ orig_stk_bytes
+ arg_ty
+ reg_params
+
+ -- make live register bitmaps
+ bmp_reg r ~(v, f, d, l)
+ = case r of VanillaReg n _ -> (a v n, f, d, l )
+ FloatReg n -> (v, a f n, d, l )
+ DoubleReg n -> (v, f, a d n, l )
+ LongReg n -> (v, f, d, a l n)
+ _ ->
+ pprPanic "GHC.StgToByteCode.layoutTuple unsupported register type"
+ (ppr r)
+ where a bmp n = bmp .|. (1 `shiftL` (n-1))
+
+ (vanilla_regs, float_regs, double_regs, long_regs)
+ = foldr bmp_reg (0, 0, 0, 0) regs
+
+ get_byte_off (x, StackParam y) = (x, fromIntegral y)
+ get_byte_off _ =
+ panic "GHC.StgToByteCode.layoutTuple get_byte_off"
+
+ in ( TupleInfo
+ { tupleSize = bytesToWords platform (ByteOff new_stk_bytes)
+ , tupleVanillaRegs = vanilla_regs
+ , tupleLongRegs = long_regs
+ , tupleFloatRegs = float_regs
+ , tupleDoubleRegs = double_regs
+ , tupleNativeStackSize = bytesToWords platform
+ (ByteOff orig_stk_bytes)
+ }
+ , sortBy (comparing snd) $
+ map (\(x, o) -> (x, o + start_off))
+ (orig_stk_params ++ map get_byte_off new_stk_params)
+ )
+
+{- Note [unboxed tuple bytecodes and tuple_BCO]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
+ return and receive arbitrary unboxed tuples, respectively. These
+ instructions use the helper data tuple_BCO and tuple_info.
+
+ The helper data is used to convert tuples between GHCs native calling
+ convention (object code), which uses stack and registers, and the bytecode
+ calling convention, which only uses the stack. See Note [GHCi TupleInfo]
+ for more details.
+
+
+ Returning a tuple
+ =================
+
+ Bytecode that returns a tuple first pushes all the tuple fields followed
+ by the appropriate tuple_info and tuple_BCO onto the stack. It then
+ executes the RETURN_TUPLE instruction, which causes the interpreter
+ to push stg_ret_t_info to the top of the stack. The stack (growing down)
+ then looks as follows:
+
+ ...
+ next_frame
+ tuple_field_1
+ tuple_field_2
+ ...
+ tuple_field_n
+ tuple_info
+ tuple_BCO
+ stg_ret_t_info <- Sp
+
+ If next_frame is bytecode, the interpreter will start executing it. If
+ it's object code, the interpreter jumps back to the scheduler, which in
+ turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native
+ calling convention using the description in tuple_info, and then jumps
+ to next_frame.
+
+
+ Receiving a tuple
+ =================
+
+ Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to
+ push a continuation, followed by jumping to the code that produces the
+ tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:
+
+ * cont_BCO: the continuation that receives the tuple
+ * tuple_info: see below
+ * tuple_BCO: see below
+
+ The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
+ instruction is executed, followed by stg_ctoi_tN_info, with N depending
+ on the number of stack words used by the tuple in the GHC native calling
+ convention. N is derived from tuple_info.
+
+ For example if we expect a tuple with three words on the stack, the stack
+ looks as follows after PUSH_ALTS_TUPLE:
+
+ ...
+ next_frame
+ cont_free_var_1
+ cont_free_var_2
+ ...
+ cont_free_var_n
+ tuple_info
+ tuple_BCO
+ cont_BCO
+ stg_ctoi_t3_info <- Sp
+
+ If the tuple is returned by object code, stg_ctoi_t3 will deal with
+ adjusting the stack pointer and converting the tuple to the bytecode
+ calling convention. See Note [GHCi unboxed tuples stack spills] for more
+ details.
+
+
+ The tuple_BCO
+ =============
+
+ The tuple_BCO is a helper bytecode object. Its main purpose is describing
+ the contents of the stack frame containing the tuple for the storage
+ manager. It contains only instructions to immediately return the tuple
+ that is already on the stack.
+
+
+ The tuple_info word
+ ===================
+
+ The tuple_info word describes the stack and STG register (e.g. R1..R6,
+ D1..D6) usage for the tuple. tuple_info contains enough information to
+ convert the tuple between the stack-only bytecode and stack+registers
+ GHC native calling conventions.
+
+ See Note [GHCi tuple layout] for more details of how the data is packed
+ in a single word.
+
+ -}
+
+tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+tupleBCO platform info pointers =
+ mkProtoBCO platform invented_name body_code (Left [])
+ 0{-no arity-} bitmap_size bitmap False{-is alts-}
+
+ where
+ {-
+ The tuple BCO is never referred to by name, so we can get away
+ with using a fake name here. We will need to change this if we want
+ to save some memory by sharing the BCO between places that have
+ the same tuple shape
+ -}
+ invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
+
+ -- the first word in the frame is the tuple_info word,
+ -- which is not a pointer
+ bitmap_size = trunc16W $ 1 + tupleSize info
+ bitmap = intsToReverseBitmap platform (fromIntegral bitmap_size) $
+ map ((+1) . fromIntegral . bytesToWords platform . snd)
+ (filter fst pointers)
+ body_code = mkSlideW 0 1 -- pop frame header
+ `snocOL` RETURN_TUPLE -- and add it again
+
-- -----------------------------------------------------------------------------
-- Deal with a CCall.
@@ -1187,10 +1433,10 @@ generateCCall
-> Sequel
-> BCEnv
-> CCallSpec -- where to call
- -> Id -- of target, for type info
- -> [AnnExpr' Id DVarSet] -- args (atoms)
+ -> Type
+ -> [StgArg] -- args (atoms)
-> BcM BCInstrList
-generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
+generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l
= do
profile <- getProfile
@@ -1200,56 +1446,40 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
addr_size_b :: ByteOff
addr_size_b = wordSize platform
+ arrayish_rep_hdr_size :: TyCon -> Maybe Int
+ arrayish_rep_hdr_size t
+ | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+ = Just (arrPtrsHdrSize profile)
+ | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
+ = Just (smallArrPtrsHdrSize profile)
+ | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+ = Just (arrWordsHdrSize profile)
+ | otherwise
+ = Nothing
+
-- Get the args on the stack, with tags and suitably
-- dereferenced for the CCall. For each arg, return the
-- depth to the first word of the bits for that arg, and the
-- ArgRep of what was actually pushed.
pargs
- :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
+ :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
pargs _ [] = return []
- pargs d (a:az)
- = let arg_ty = unwrapType (exprType (deAnnotate' a))
-
- in case tyConAppTyCon_maybe arg_ty of
- -- Don't push the FO; instead push the Addr# it
- -- contains.
- Just t
- | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
- -> do rest <- pargs (d + addr_size_b) az
- code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize profile)) d p a
- return ((code,AddrRep):rest)
-
- | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
- -> do rest <- pargs (d + addr_size_b) az
- code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize profile)) d p a
- return ((code,AddrRep):rest)
-
- | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
- -> do rest <- pargs (d + addr_size_b) az
- code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize profile)) d p a
- return ((code,AddrRep):rest)
-
- -- Default case: push taggedly, but otherwise intact.
- _
- -> do (code_a, sz_a) <- pushAtom d p a
- rest <- pargs (d + sz_a) az
- return ((code_a, atomPrimRep a) : rest)
-
- -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
- -- the stack but then advance it over the headers, so as to
- -- point to the payload.
- parg_ArrayishRep
- :: Word16
- -> StackDepth
- -> BCEnv
- -> AnnExpr' Id DVarSet
- -> BcM BCInstrList
- parg_ArrayishRep hdrSize d p a
- = do (push_fo, _) <- pushAtom d p a
+ pargs d (aa@(StgVarArg a):az)
+ | Just t <- tyConAppTyCon_maybe (idType a)
+ , Just hdr_sz <- arrayish_rep_hdr_size t
+ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
+ -- the stack but then advance it over the headers, so as to
+ -- point to the payload.
+ = do rest <- pargs (d + addr_size_b) az
+ (push_fo, _) <- pushAtom d p aa
-- The ptr points at the header. Advance it over the
-- header and then pretend this is an Addr#.
- return (push_fo `snocOL` SWIZZLE 0 hdrSize)
+ let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)
+ return ((code, AddrRep) : rest)
+ pargs d (aa:az) = do (code_a, sz_a) <- pushAtom d p aa
+ rest <- pargs (d + sz_a) az
+ return ((code_a, atomPrimRep aa) : rest)
code_n_reps <- pargs d0 args_r_to_l
let
@@ -1260,7 +1490,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
!d_after_args = d0 + wordsToBytes platform a_reps_sizeW
a_reps_pushed_RAW
| null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))
- = panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?"
+ = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"
| otherwise
= reverse (tail a_reps_pushed_r_to_l)
@@ -1270,7 +1500,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-- Get the result rep.
(returns_void, r_rep)
- = case maybe_getCCallReturnRep (idType fn) of
+ = case maybe_getCCallReturnRep result_ty of
Nothing -> (True, VoidRep)
Just rr -> (False, rr)
{-
@@ -1332,7 +1562,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
| is_static = a_reps_pushed_RAW
| otherwise = if null a_reps_pushed_RAW
- then panic "GHC.CoreToByteCode.generateCCall: dyn with no args"
+ then panic "GHC.StgToByteCode.generateCCall: dyn with no args"
else tail a_reps_pushed_RAW
-- push the Addr#
@@ -1362,7 +1592,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
conv = case cconv of
CCallConv -> FFICCall
StdCallConv -> FFIStdCall
- _ -> panic "GHC.CoreToByteCode: unexpected calling convention"
+ _ -> panic "GHC.StgToByteCode: unexpected calling convention"
-- the only difference in libffi mode is that we prepare a cif
-- describing the call type by calling libffi, and we attach the
@@ -1472,14 +1702,10 @@ maybe_getCCallReturnRep fn_ty
-- valid return value placeholder on the stack
_ -> blargh
-maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
+maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
-- Detect and extract relevant info for the tagToEnum kludge.
-maybe_is_tagToEnum_call app
- | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
- , Just TagToEnumOp <- isPrimOpId_maybe v
- = Just (snd arg, extract_constr_Names t)
- | otherwise
- = Nothing
+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)
+ = Just (v, extract_constr_Names t)
where
extract_constr_Names ty
| rep_ty <- unwrapType ty
@@ -1490,6 +1716,7 @@ maybe_is_tagToEnum_call app
-- the DataCon. See "GHC.Core.DataCon" for details.
| otherwise
= pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+maybe_is_tagToEnum_call _ = Nothing
{- -----------------------------------------------------------------------------
Note [Implementing tagToEnum#]
@@ -1533,13 +1760,13 @@ implement_tagToId
:: StackDepth
-> Sequel
-> BCEnv
- -> AnnExpr' Id DVarSet
+ -> Id
-> [Name]
-> BcM BCInstrList
-- See Note [Implementing tagToEnum#]
implement_tagToId d s p arg names
= ASSERT( notNull names )
- do (push_arg, arg_bytes) <- pushAtom d p arg
+ do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
labels <- getLabelsBc (genericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
@@ -1582,21 +1809,12 @@ implement_tagToId d s p arg names
-- depth 6 stack has valid words 0 .. 5.
pushAtom
- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
-pushAtom d p e
- | Just e' <- bcView e
- = pushAtom d p e'
-
-pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things,
- = return (nilOL, 0) -- treated just like a variable V
+ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
-- See Note [Empty case alternatives] in GHC.Core
-- and Note [Bottoming expressions] in GHC.Core.Utils:
-- The scrutinee of an empty case evaluates to bottom
-pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
- = pushAtom d p a
-
-pushAtom d p (AnnVar var)
+pushAtom d p (StgVarArg var)
| [] <- typePrimRep (idType var)
= return (nilOL, 0)
@@ -1635,15 +1853,14 @@ pushAtom d p (AnnVar var)
= do topStrings <- getTopStrings
platform <- targetPlatform <$> getDynFlags
case lookupVarEnv topStrings var of
- Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $
+ Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
Nothing -> do
let sz = idSizeCon platform var
MASSERT( sz == wordSize platform )
return (unitOL (PUSH_G (getName var)), sz)
-
-pushAtom _ _ (AnnLit lit) = do
+pushAtom _ _ (StgLitArg lit) = do
platform <- targetPlatform <$> getDynFlags
let code :: PrimRep -> BcM (BCInstrList, ByteOff)
code rep =
@@ -1684,21 +1901,15 @@ pushAtom _ _ (AnnLit lit) = do
LitNumInteger -> panic "pushAtom: LitInteger"
LitNumNatural -> panic "pushAtom: LitNatural"
-pushAtom _ _ expr
- = pprPanic "GHC.CoreToByteCode.pushAtom"
- (pprCoreExpr (deAnnotate' expr))
-
-
-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
-- This is slightly different to @pushAtom@ due to the fact that we allow
-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
pushConstrAtom
- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
-
-pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
+ :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
+pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) =
return (unitOL (PUSH_UBX32 lit), 4)
-pushConstrAtom d p (AnnVar v)
+pushConstrAtom d p va@(StgVarArg v)
| Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable
platform <- targetPlatform <$> getDynFlags
let !szb = idSizeCon platform v
@@ -1709,7 +1920,7 @@ pushConstrAtom d p (AnnVar v)
1 -> done PUSH8
2 -> done PUSH16
4 -> done PUSH32
- _ -> pushAtom d p (AnnVar v)
+ _ -> pushAtom d p va
pushConstrAtom d p expr = pushAtom d p expr
@@ -1869,7 +2080,14 @@ idSizeW :: Platform -> Id -> WordOff
idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
idSizeCon :: Platform -> Id -> ByteOff
-idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
+idSizeCon platform var
+ -- unboxed tuple components are padded to word size
+ | isUnboxedTupleType (idType var) ||
+ isUnboxedSumType (idType var) =
+ wordsToBytes platform .
+ WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
+ bcIdPrimReps $ var
+ | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
bcIdArgRep :: Platform -> Id -> ArgRep
bcIdArgRep platform = toArgRep platform . bcIdPrimRep
@@ -1881,6 +2099,10 @@ bcIdPrimRep id
| otherwise
= pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
+
+bcIdPrimReps :: Id -> [PrimRep]
+bcIdPrimReps id = typePrimRepArgs (idType id)
+
repSizeWords :: Platform -> PrimRep -> WordOff
repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
@@ -1888,17 +2110,6 @@ isFollowableArg :: ArgRep -> Bool
isFollowableArg P = True
isFollowableArg _ = False
-isVoidArg :: ArgRep -> Bool
-isVoidArg V = True
-isVoidArg _ = False
-
--- See bug #1257
-multiValException :: a
-multiValException = throwGhcException (ProgramError
- ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
- " Possibly due to foreign import/export decls in source.\n"++
- " Workaround: use -fobject-code, or compile this module to .o separately."))
-
-- | Indicate if the calling convention is supported
isSupportedCConv :: CCallSpec -> Bool
isSupportedCConv (CCallSpec _ cconv _) = case cconv of
@@ -1934,62 +2145,11 @@ mkSlideW !n !ws
limit :: Word16
limit = maxBound
-splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
- -- The arguments are returned in *right-to-left* order
-splitApp e | Just e' <- bcView e = splitApp e'
-splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
- (f', as) -> (f', a:as)
-splitApp e = (e, [])
-
-
-bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
--- The "bytecode view" of a term discards
--- a) type abstractions
--- b) type applications
--- c) casts
--- d) ticks (but not breakpoints)
--- e) case unsafeEqualityProof of UnsafeRefl -> e ==> e
--- Type lambdas *can* occur in random expressions,
--- whereas value lambdas cannot; that is why they are nuked here
-bcView (AnnCast (_,e) _) = Just e
-bcView (AnnLam v (_,e)) | isTyVar v = Just e
-bcView (AnnApp (_,e) (_, AnnType _)) = Just e
-bcView (AnnTick Breakpoint{} _) = Nothing
-bcView (AnnTick _other_tick (_,e)) = Just e
-bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof
- | AnnVar id <- bcViewLoop e
- , idName id == unsafeEqualityProofName
- , [AnnAlt _ _ (_, rhs)] <- alts
- = Just rhs
-bcView _ = Nothing
-
-bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann
-bcViewLoop e =
- case bcView e of
- Nothing -> e
- Just e' -> bcViewLoop e'
-
-isVAtom :: Platform -> AnnExpr' Var ann -> Bool
-isVAtom platform expr = case expr of
- e | Just e' <- bcView e -> isVAtom platform e'
- (AnnVar v) -> isVoidArg (bcIdArgRep platform v)
- (AnnCoercion {}) -> True
- _ -> False
-
-atomPrimRep :: AnnExpr' Id ann -> PrimRep
-atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
-atomPrimRep (AnnVar v) = bcIdPrimRep v
-atomPrimRep (AnnLit l) = typePrimRep1 (literalType l)
-
--- #12128:
--- A case expression can be an atom because empty cases evaluate to bottom.
--- See Note [Empty case alternatives] in GHC.Core
-atomPrimRep (AnnCase _ _ ty _) =
- ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep
-atomPrimRep (AnnCoercion {}) = VoidRep
-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
+atomPrimRep :: StgArg -> PrimRep
+atomPrimRep (StgVarArg v) = bcIdPrimRep v
+atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
-atomRep :: Platform -> AnnExpr' Id ann -> ArgRep
+atomRep :: Platform -> StgArg -> ArgRep
atomRep platform e = toArgRep platform (atomPrimRep e)
-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
@@ -1998,8 +2158,8 @@ atomRep platform e = toArgRep platform (atomPrimRep e)
mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
-typeArgRep :: Platform -> Type -> ArgRep
-typeArgRep platform = toArgRep platform . typePrimRep1
+typeArgReps :: Platform -> Type -> [ArgRep]
+typeArgReps platform = map (toArgRep platform) . typePrimRepArgs
-- -----------------------------------------------------------------------------
-- The bytecode generator's monad
@@ -2088,7 +2248,7 @@ getLabelsBc n
getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
getCCArray = BcM $ \st ->
- let breaks = expectJust "GHC.CoreToByteCode.getCCArray" $ modBreaks st in
+ let breaks = expectJust "GHC.StgToByteCode.getCCArray" $ modBreaks st in
return (st, modBreaks_ccs breaks)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 76d225bd57bcdc0dafdd0b15d19aa61957a3a231..ded5bc4c073dfdc234a82515828f080fd56d8d67 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -335,7 +335,6 @@ Library
GHC.Core.Stats
GHC.Core.Subst
GHC.Core.Tidy
- GHC.CoreToByteCode
GHC.CoreToIface
GHC.CoreToStg
GHC.CoreToStg.Prep
@@ -536,6 +535,7 @@ Library
GHC.Stg.Stats
GHC.Stg.Subst
GHC.Stg.Syntax
+ GHC.StgToByteCode
GHC.StgToCmm
GHC.StgToCmm.ArgRep
GHC.StgToCmm.Bind
diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
index f7a0d6f151c727c39f21dfe48bbf9f095d988945..859892de2da490f0af8c8fe644687a74d2698856 100644
--- a/includes/rts/Bytecodes.h
+++ b/includes/rts/Bytecodes.h
@@ -91,6 +91,9 @@
#define bci_BRK_FUN 66
#define bci_TESTLT_W 67
#define bci_TESTEQ_W 68
+
+#define bci_RETURN_T 69
+#define bci_PUSH_ALTS_T 70
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 43e099a0d668d55548f28971303dfde4d6b9fcea..d8aefd80358b1350c05cebccead896e6f3f6306c 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -87,6 +87,77 @@ RTS_RET(stg_ctoi_D1);
RTS_RET(stg_ctoi_L1);
RTS_RET(stg_ctoi_V);
+RTS_FUN_DECL(stg_ctoi_t);
+RTS_RET(stg_ctoi_t0);
+RTS_RET(stg_ctoi_t1);
+RTS_RET(stg_ctoi_t2);
+RTS_RET(stg_ctoi_t3);
+RTS_RET(stg_ctoi_t4);
+RTS_RET(stg_ctoi_t5);
+RTS_RET(stg_ctoi_t6);
+RTS_RET(stg_ctoi_t7);
+RTS_RET(stg_ctoi_t8);
+RTS_RET(stg_ctoi_t9);
+
+RTS_RET(stg_ctoi_t10);
+RTS_RET(stg_ctoi_t11);
+RTS_RET(stg_ctoi_t12);
+RTS_RET(stg_ctoi_t13);
+RTS_RET(stg_ctoi_t14);
+RTS_RET(stg_ctoi_t15);
+RTS_RET(stg_ctoi_t16);
+RTS_RET(stg_ctoi_t17);
+RTS_RET(stg_ctoi_t18);
+RTS_RET(stg_ctoi_t19);
+
+RTS_RET(stg_ctoi_t20);
+RTS_RET(stg_ctoi_t21);
+RTS_RET(stg_ctoi_t22);
+RTS_RET(stg_ctoi_t23);
+RTS_RET(stg_ctoi_t24);
+RTS_RET(stg_ctoi_t25);
+RTS_RET(stg_ctoi_t26);
+RTS_RET(stg_ctoi_t27);
+RTS_RET(stg_ctoi_t28);
+RTS_RET(stg_ctoi_t29);
+
+RTS_RET(stg_ctoi_t30);
+RTS_RET(stg_ctoi_t31);
+RTS_RET(stg_ctoi_t32);
+RTS_RET(stg_ctoi_t33);
+RTS_RET(stg_ctoi_t34);
+RTS_RET(stg_ctoi_t35);
+RTS_RET(stg_ctoi_t36);
+RTS_RET(stg_ctoi_t37);
+RTS_RET(stg_ctoi_t38);
+RTS_RET(stg_ctoi_t39);
+
+RTS_RET(stg_ctoi_t40);
+RTS_RET(stg_ctoi_t41);
+RTS_RET(stg_ctoi_t42);
+RTS_RET(stg_ctoi_t43);
+RTS_RET(stg_ctoi_t44);
+RTS_RET(stg_ctoi_t45);
+RTS_RET(stg_ctoi_t46);
+RTS_RET(stg_ctoi_t47);
+RTS_RET(stg_ctoi_t48);
+RTS_RET(stg_ctoi_t49);
+
+RTS_RET(stg_ctoi_t50);
+RTS_RET(stg_ctoi_t51);
+RTS_RET(stg_ctoi_t52);
+RTS_RET(stg_ctoi_t53);
+RTS_RET(stg_ctoi_t54);
+RTS_RET(stg_ctoi_t55);
+RTS_RET(stg_ctoi_t56);
+RTS_RET(stg_ctoi_t57);
+RTS_RET(stg_ctoi_t58);
+RTS_RET(stg_ctoi_t59);
+
+RTS_RET(stg_ctoi_t60);
+RTS_RET(stg_ctoi_t61);
+RTS_RET(stg_ctoi_t62);
+
RTS_RET(stg_apply_interp);
RTS_ENTRY(stg_IND);
@@ -292,6 +363,7 @@ RTS_RET(stg_ret_n);
RTS_RET(stg_ret_f);
RTS_RET(stg_ret_d);
RTS_RET(stg_ret_l);
+RTS_RET(stg_ret_t);
RTS_FUN_DECL(stg_gc_prim);
RTS_FUN_DECL(stg_gc_prim_p);
diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs
index 51bf3466eba66748be52c6f945e33c373324071d..2c139288015a299fab6eb42881f9c5784c54fb47 100644
--- a/libraries/ghci/GHCi/BreakArray.hs
+++ b/libraries/ghci/GHCi/BreakArray.hs
@@ -24,7 +24,7 @@
module GHCi.BreakArray
(
BreakArray
- (BA) -- constructor is exported only for GHC.CoreToByteCode
+ (BA) -- constructor is exported only for GHC.StgToByteCode
, newBreakArray
, getBreak
, setupBreakpoint
diff --git a/rts/Disassembler.c b/rts/Disassembler.c
index 67a451e7e636e279ab11652ad9a23cc93b6fdfb4..451521d57e66fef193d1fa67c4cd3207aaedbcb4 100644
--- a/rts/Disassembler.c
+++ b/rts/Disassembler.c
@@ -148,6 +148,13 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("PUSH_ALTS_V " ); printPtr( ptrs[instrs[pc]] );
debugBelch("\n");
pc += 1; break;
+ case bci_PUSH_ALTS_T:
+ debugBelch("PUSH_ALTS_T ");
+ printPtr( ptrs[instrs[pc]] );
+ debugBelch(" 0x%" FMT_HexWord " ", literals[instrs[pc+1]] );
+ printPtr( ptrs[instrs[pc+2]] );
+ debugBelch("\n");
+ pc += 3; break;
case bci_PUSH_PAD8:
debugBelch("PUSH_PAD8\n");
pc += 1; break;
@@ -310,6 +317,9 @@ disInstr ( StgBCO *bco, int pc )
case bci_RETURN_V:
debugBelch("RETURN_V\n" );
break;
+ case bci_RETURN_T:
+ debugBelch("RETURN_T\n ");
+ break;
default:
barf("disInstr: unknown opcode %u", (unsigned int) instr);
@@ -317,12 +327,6 @@ disInstr ( StgBCO *bco, int pc )
return pc;
}
-
-/* Something of a kludge .. how do we know where the end of the insn
- array is, since it isn't recorded anywhere? Answer: the first
- short is the number of bytecodes which follow it.
- See GHC.CoreToByteCode.linkBCO.insns_arr for construction ...
-*/
void disassemble( StgBCO *bco )
{
uint32_t i, j;
diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 6929aec5fdedada197e30f160cf9a2d20c3944fe..efbfd091d8a11b387345845e01ced54fa8ce1b4b 100644
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -4,6 +4,7 @@
* Copyright (c) The GHC Team, 1994-2002.
* ---------------------------------------------------------------------------*/
+
#include "PosixSource.h"
#include "Rts.h"
#include "RtsAPI.h"
@@ -681,12 +682,13 @@ do_return_unboxed:
|| SpW(0) == (W_)&stg_ret_f_info
|| SpW(0) == (W_)&stg_ret_d_info
|| SpW(0) == (W_)&stg_ret_l_info
+ || SpW(0) == (W_)&stg_ret_t_info
);
IF_DEBUG(interpreter,
debugBelch(
"\n---------------------------------------------------------------\n");
- debugBelch("Returning: "); printObj(obj);
+ debugBelch("Returning unboxed\n");
debugBelch("Sp = %p\n", Sp);
#if defined(PROFILING)
fprintCCS(stderr, cap->r.rCCCS);
@@ -697,7 +699,7 @@ do_return_unboxed:
debugBelch("\n\n");
);
- // get the offset of the stg_ctoi_ret_XXX itbl
+ // get the offset of the header of the next stack frame
offset = stack_frame_sizeW((StgClosure *)Sp);
switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
@@ -934,6 +936,43 @@ run_BCO_return_unboxed:
// Stack checks aren't necessary at return points, the stack use
// is aggregated into the enclosing function entry point.
+#if defined(PROFILING)
+ /*
+ Restore the current cost centre stack if a tuple is being returned.
+
+ When a "simple" unboxed value is returned, the cccs is restored with
+ an stg_restore_cccs frame on the stack, for example:
+
+ ...
+ stg_ctoi_D1
+ <CCCS>
+ stg_restore_cccs
+
+ But stg_restore_cccs cannot deal with tuples, which may have more
+ things on the stack. Therefore we store the CCCS inside the
+ stg_ctoi_t frame.
+
+ If we have a tuple being returned, the stack looks like this:
+
+ ...
+ <CCCS> <- to restore, Sp offset <next frame + 4 words>
+ tuple_BCO
+ tuple_info
+ cont_BCO
+ stg_ctoi_t <- next frame
+ tuple_data_1
+ ...
+ tuple_data_n
+ tuple_info
+ tuple_BCO
+ stg_ret_t <- Sp
+ */
+
+ if(SpW(0) == (W_)&stg_ret_t_info) {
+ cap->r.rCCCS = (CostCentreStack*)SpW(stack_frame_sizeW((StgClosure *)Sp) + 4);
+ }
+#endif
+
goto run_BCO;
run_BCO_fun:
@@ -1329,6 +1368,100 @@ run_BCO:
goto nextInsn;
}
+ case bci_PUSH_ALTS_T: {
+ int o_bco = BCO_GET_LARGE_ARG;
+ W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
+ int o_tuple_bco = BCO_GET_LARGE_ARG;
+
+#if defined(PROFILING)
+ SpW(-1) = (W_)cap->r.rCCCS;
+ Sp_subW(1);
+#endif
+
+ SpW(-1) = BCO_PTR(o_tuple_bco);
+ SpW(-2) = tuple_info;
+ SpW(-3) = BCO_PTR(o_bco);
+ W_ ctoi_t_offset;
+ int tuple_stack_words = tuple_info & 0x3fff;
+ switch(tuple_stack_words) {
+ case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break;
+ case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break;
+ case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break;
+ case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break;
+ case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break;
+ case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break;
+ case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break;
+ case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break;
+ case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break;
+ case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break;
+
+ case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
+ case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
+ case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
+ case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
+ case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
+ case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
+ case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
+ case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
+ case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
+ case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
+
+ case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
+ case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
+ case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
+ case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
+ case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
+ case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
+ case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
+ case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
+ case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
+ case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
+
+ case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
+ case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
+ case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
+ case 33: ctoi_t_offset = (W_)&stg_ctoi_t33_info; break;
+ case 34: ctoi_t_offset = (W_)&stg_ctoi_t34_info; break;
+ case 35: ctoi_t_offset = (W_)&stg_ctoi_t35_info; break;
+ case 36: ctoi_t_offset = (W_)&stg_ctoi_t36_info; break;
+ case 37: ctoi_t_offset = (W_)&stg_ctoi_t37_info; break;
+ case 38: ctoi_t_offset = (W_)&stg_ctoi_t38_info; break;
+ case 39: ctoi_t_offset = (W_)&stg_ctoi_t39_info; break;
+
+ case 40: ctoi_t_offset = (W_)&stg_ctoi_t40_info; break;
+ case 41: ctoi_t_offset = (W_)&stg_ctoi_t41_info; break;
+ case 42: ctoi_t_offset = (W_)&stg_ctoi_t42_info; break;
+ case 43: ctoi_t_offset = (W_)&stg_ctoi_t43_info; break;
+ case 44: ctoi_t_offset = (W_)&stg_ctoi_t44_info; break;
+ case 45: ctoi_t_offset = (W_)&stg_ctoi_t45_info; break;
+ case 46: ctoi_t_offset = (W_)&stg_ctoi_t46_info; break;
+ case 47: ctoi_t_offset = (W_)&stg_ctoi_t47_info; break;
+ case 48: ctoi_t_offset = (W_)&stg_ctoi_t48_info; break;
+ case 49: ctoi_t_offset = (W_)&stg_ctoi_t49_info; break;
+
+ case 50: ctoi_t_offset = (W_)&stg_ctoi_t50_info; break;
+ case 51: ctoi_t_offset = (W_)&stg_ctoi_t51_info; break;
+ case 52: ctoi_t_offset = (W_)&stg_ctoi_t52_info; break;
+ case 53: ctoi_t_offset = (W_)&stg_ctoi_t53_info; break;
+ case 54: ctoi_t_offset = (W_)&stg_ctoi_t54_info; break;
+ case 55: ctoi_t_offset = (W_)&stg_ctoi_t55_info; break;
+ case 56: ctoi_t_offset = (W_)&stg_ctoi_t56_info; break;
+ case 57: ctoi_t_offset = (W_)&stg_ctoi_t57_info; break;
+ case 58: ctoi_t_offset = (W_)&stg_ctoi_t58_info; break;
+ case 59: ctoi_t_offset = (W_)&stg_ctoi_t59_info; break;
+
+ case 60: ctoi_t_offset = (W_)&stg_ctoi_t60_info; break;
+ case 61: ctoi_t_offset = (W_)&stg_ctoi_t61_info; break;
+ case 62: ctoi_t_offset = (W_)&stg_ctoi_t62_info; break;
+
+ default: barf("unsupported tuple size %d", tuple_stack_words);
+ }
+
+ SpW(-4) = ctoi_t_offset;
+ Sp_subW(4);
+ goto nextInsn;
+ }
+
case bci_PUSH_APPLY_N:
Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
goto nextInsn;
@@ -1708,6 +1841,12 @@ run_BCO:
Sp_subW(1);
SpW(0) = (W_)&stg_ret_v_info;
goto do_return_unboxed;
+ case bci_RETURN_T: {
+ /* tuple_info and tuple_bco must already be on the stack */
+ Sp_subW(1);
+ SpW(0) = (W_)&stg_ret_t_info;
+ goto do_return_unboxed;
+ }
case bci_SWIZZLE: {
int stkoff = BCO_NEXT;
diff --git a/rts/Printer.c b/rts/Printer.c
index ef9a52719b814a5c3e2a7c5f0e517ad9b0193df7..7d9614cfd75134182e56ec96d485b07c8406a8cc 100644
--- a/rts/Printer.c
+++ b/rts/Printer.c
@@ -529,17 +529,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
case RET_SMALL: {
StgWord c = *sp;
- if (c == (StgWord)&stg_ctoi_R1p_info) {
- debugBelch("tstg_ctoi_ret_R1p_info\n" );
- } else if (c == (StgWord)&stg_ctoi_R1n_info) {
- debugBelch("stg_ctoi_ret_R1n_info\n" );
- } else if (c == (StgWord)&stg_ctoi_F1_info) {
- debugBelch("stg_ctoi_ret_F1_info\n" );
- } else if (c == (StgWord)&stg_ctoi_D1_info) {
- debugBelch("stg_ctoi_ret_D1_info\n" );
- } else if (c == (StgWord)&stg_ctoi_V_info) {
- debugBelch("stg_ctoi_ret_V_info\n" );
- } else if (c == (StgWord)&stg_ap_v_info) {
+ if (c == (StgWord)&stg_ap_v_info) {
debugBelch("stg_ap_v_info\n" );
} else if (c == (StgWord)&stg_ap_f_info) {
debugBelch("stg_ap_f_info\n" );
@@ -595,11 +585,51 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
}
case RET_BCO: {
- StgBCO *bco;
-
- bco = ((StgBCO *)sp[1]);
+ StgWord c = *sp;
+ StgBCO *bco = ((StgBCO *)sp[1]);
- debugBelch("RET_BCO (%p)\n", sp);
+ if (c == (StgWord)&stg_ctoi_R1p_info) {
+ debugBelch("stg_ctoi_R1p_info" );
+ } else if (c == (StgWord)&stg_ctoi_R1unpt_info) {
+ debugBelch("stg_ctoi_R1unpt_info" );
+ } else if (c == (StgWord)&stg_ctoi_R1n_info) {
+ debugBelch("stg_ctoi_R1n_info" );
+ } else if (c == (StgWord)&stg_ctoi_F1_info) {
+ debugBelch("stg_ctoi_F1_info" );
+ } else if (c == (StgWord)&stg_ctoi_D1_info) {
+ debugBelch("stg_ctoi_D1_info" );
+ } else if (c == (StgWord)&stg_ctoi_V_info) {
+ debugBelch("stg_ctoi_V_info" );
+ } else if (c == (StgWord)&stg_BCO_info) {
+ debugBelch("stg_BCO_info" );
+ } else if (c == (StgWord)&stg_apply_interp_info) {
+ debugBelch("stg_apply_interp_info" );
+ } else if (c == (StgWord)&stg_ret_t_info) {
+ debugBelch("stg_ret_t_info" );
+ } else if (c == (StgWord)&stg_ctoi_t0_info) {
+ debugBelch("stg_ctoi_t0_info" );
+ } else if (c == (StgWord)&stg_ctoi_t1_info) {
+ debugBelch("stg_ctoi_t1_info" );
+ } else if (c == (StgWord)&stg_ctoi_t2_info) {
+ debugBelch("stg_ctoi_t2_info" );
+ } else if (c == (StgWord)&stg_ctoi_t3_info) {
+ debugBelch("stg_ctoi_t3_info" );
+ } else if (c == (StgWord)&stg_ctoi_t4_info) {
+ debugBelch("stg_ctoi_t4_info" );
+ } else if (c == (StgWord)&stg_ctoi_t5_info) {
+ debugBelch("stg_ctoi_t5_info" );
+ } else if (c == (StgWord)&stg_ctoi_t6_info) {
+ debugBelch("stg_ctoi_t6_info" );
+ } else if (c == (StgWord)&stg_ctoi_t7_info) {
+ debugBelch("stg_ctoi_t7_info" );
+ } else if (c == (StgWord)&stg_ctoi_t8_info) {
+ debugBelch("stg_ctoi_t8_info" );
+ /* there are more stg_ctoi_tN_info frames,
+ but we don't print them all */
+ } else {
+ debugBelch("RET_BCO");
+ }
+ debugBelch(" (%p)\n", sp);
printLargeBitmap(spBottom, sp+2,
BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
continue;
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 50a3bae267277b2202564527a045b3cc4c5430c8..3a9f568ed4da4814944fe575941a6bc807ea6147 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -561,6 +561,8 @@
SymI_HasProto(stg_ret_f_info) \
SymI_HasProto(stg_ret_d_info) \
SymI_HasProto(stg_ret_l_info) \
+ SymI_HasProto(stg_ret_t_info) \
+ SymI_HasProto(stg_ctoi_t) \
SymI_HasProto(stg_gc_prim_p) \
SymI_HasProto(stg_gc_prim_pp) \
SymI_HasProto(stg_gc_prim_n) \
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 7a8f20dded18b667fb16527982ad6c3578a2eeb5..b9379ab3e6f42da5248a9a9e0a6e5b6919a0c597 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -195,6 +195,274 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
jump stg_yield_to_interpreter [];
}
+/* Note [GHCi unboxed tuples stack spills]
+
+ In the calling convention for compiled code, a tuple is returned
+ in registers, with everything that doesn't fit spilled onto the STG
+ stack.
+
+ At the time the continuation is called, Sp points to the highest word
+ used on the stack:
+
+ ...
+ stg_ctoi_t (next stack frame, continuation)
+ spilled_1
+ spilled_2
+ spilled_3 <- Sp
+
+ This makes it difficult to write a procedure that can handle tuples of
+ any size.
+
+ To get around this, we use a Cmm procedure that adjusts the stack pointer
+ to skip over the tuple:
+
+ ...
+ stg_ctoi_t3 (advances Sp by 3 words, then calls stg_ctoi_t)
+ spilled_1
+ spilled_2
+ spilled_3 <- Sp
+
+ When stg_ctoi_t is called, the stack looks like:
+
+ ...
+ tuple_BCO
+ tuple_info
+ cont_BCO (continuation in bytecode)
+ stg_ctoi_t3 <- Sp
+ spilled_1
+ spilled_2
+ spilled_3
+
+ stg_ctoi_t then reads the tuple_info word to determine the registers
+ to save onto the stack and construct a call to tuple_BCO. Afterwards the
+ stack looks as follows:
+
+ ...
+ tuple_BCO
+ tuple_info
+ cont_BCO
+ stg_ctoi_t3
+ spilled_1
+ spilled_2
+ spilled_3
+ saved_R2
+ saved_R1
+ saved_D3
+ ...
+ tuple_BCO
+ stg_apply_interp <- Sp
+
+
+ tuple_BCO contains the bytecode instructions to return the tuple to
+ cont_BCO. The bitmap in tuple_BCO describes the contents of
+ the tuple to the storage manager.
+
+ At this point we can safely jump to the interpreter.
+
+ */
+
+#define MK_STG_CTOI_T(N) INFO_TABLE_RET( \
+ stg_ctoi_t ## N, RET_BCO ) \
+ { Sp_adj(N); jump stg_ctoi_t [*]; }
+
+MK_STG_CTOI_T(0)
+MK_STG_CTOI_T(1)
+MK_STG_CTOI_T(2)
+MK_STG_CTOI_T(3)
+MK_STG_CTOI_T(4)
+MK_STG_CTOI_T(5)
+MK_STG_CTOI_T(6)
+MK_STG_CTOI_T(7)
+MK_STG_CTOI_T(8)
+MK_STG_CTOI_T(9)
+
+MK_STG_CTOI_T(10)
+MK_STG_CTOI_T(11)
+MK_STG_CTOI_T(12)
+MK_STG_CTOI_T(13)
+MK_STG_CTOI_T(14)
+MK_STG_CTOI_T(15)
+MK_STG_CTOI_T(16)
+MK_STG_CTOI_T(17)
+MK_STG_CTOI_T(18)
+MK_STG_CTOI_T(19)
+
+MK_STG_CTOI_T(20)
+MK_STG_CTOI_T(21)
+MK_STG_CTOI_T(22)
+MK_STG_CTOI_T(23)
+MK_STG_CTOI_T(24)
+MK_STG_CTOI_T(25)
+MK_STG_CTOI_T(26)
+MK_STG_CTOI_T(27)
+MK_STG_CTOI_T(28)
+MK_STG_CTOI_T(29)
+
+MK_STG_CTOI_T(30)
+MK_STG_CTOI_T(31)
+MK_STG_CTOI_T(32)
+MK_STG_CTOI_T(33)
+MK_STG_CTOI_T(34)
+MK_STG_CTOI_T(35)
+MK_STG_CTOI_T(36)
+MK_STG_CTOI_T(37)
+MK_STG_CTOI_T(38)
+MK_STG_CTOI_T(39)
+
+MK_STG_CTOI_T(40)
+MK_STG_CTOI_T(41)
+MK_STG_CTOI_T(42)
+MK_STG_CTOI_T(43)
+MK_STG_CTOI_T(44)
+MK_STG_CTOI_T(45)
+MK_STG_CTOI_T(46)
+MK_STG_CTOI_T(47)
+MK_STG_CTOI_T(48)
+MK_STG_CTOI_T(49)
+
+MK_STG_CTOI_T(50)
+MK_STG_CTOI_T(51)
+MK_STG_CTOI_T(52)
+MK_STG_CTOI_T(53)
+MK_STG_CTOI_T(54)
+MK_STG_CTOI_T(55)
+MK_STG_CTOI_T(56)
+MK_STG_CTOI_T(57)
+MK_STG_CTOI_T(58)
+MK_STG_CTOI_T(59)
+
+MK_STG_CTOI_T(60)
+MK_STG_CTOI_T(61)
+MK_STG_CTOI_T(62)
+
+/*
+ Note [GHCi tuple layout]
+
+ the tuple_info word describes the register and stack usage of the tuple:
+
+ [ rrrr ffff ffdd dddd llss ssss ssss ssss ]
+
+ - r: number of vanilla registers R1..Rn
+ - f: bitmap of float registers F1..F6
+ - d: bitmap of double registers D1..D6
+ - l: bitmap of long registers L1..Ln
+ - s: number of words on stack (in addition to registers)
+
+ The order in which the registers are pushed on the stack is determined by
+ the Ord instance of GHC.Cmm.Expr.GlobalReg. If you change the Ord instance,
+ the order in stg_ctoi_t and stg_ret_t needs to be adjusted accordingly.
+
+ */
+
+stg_ctoi_t
+ /* explicit stack */
+{
+
+ W_ tuple_info, tuple_stack, tuple_regs_R,
+ tuple_regs_F, tuple_regs_D, tuple_regs_L;
+ P_ tuple_BCO;
+
+ tuple_info = Sp(2); /* tuple information word */
+ tuple_BCO = Sp(3); /* bytecode object that returns the tuple in
+ the interpreter */
+
+#if defined(PROFILING)
+ CCCS = Sp(4);
+#endif
+
+ tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */
+ tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */
+ tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */
+ tuple_regs_D = (tuple_info >> 16) & 0x3f; /* 6 bits bitmap */
+ tuple_regs_L = (tuple_info >> 14) & 0x3; /* 2 bits bitmap */
+
+ Sp = Sp - WDS(tuple_stack);
+
+ /* save long registers */
+ /* fixme L2 ? */
+ if((tuple_regs_L & 1) != 0) { Sp = Sp - 8; L_[Sp] = L1; }
+
+ /* save double registers */
+ if((tuple_regs_D & 32) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D6; }
+ if((tuple_regs_D & 16) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D5; }
+ if((tuple_regs_D & 8) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D4; }
+ if((tuple_regs_D & 4) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D3; }
+ if((tuple_regs_D & 2) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D2; }
+ if((tuple_regs_D & 1) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D1; }
+
+ /* save float registers */
+ if((tuple_regs_F & 32) != 0) { Sp_adj(-1); F_[Sp] = F6; }
+ if((tuple_regs_F & 16) != 0) { Sp_adj(-1); F_[Sp] = F5; }
+ if((tuple_regs_F & 8) != 0) { Sp_adj(-1); F_[Sp] = F4; }
+ if((tuple_regs_F & 4) != 0) { Sp_adj(-1); F_[Sp] = F3; }
+ if((tuple_regs_F & 2) != 0) { Sp_adj(-1); F_[Sp] = F2; }
+ if((tuple_regs_F & 1) != 0) { Sp_adj(-1); F_[Sp] = F1; }
+
+ /* save vanilla registers */
+ if(tuple_regs_R >= 6) { Sp_adj(-1); Sp(0) = R6; }
+ if(tuple_regs_R >= 5) { Sp_adj(-1); Sp(0) = R5; }
+ if(tuple_regs_R >= 4) { Sp_adj(-1); Sp(0) = R4; }
+ if(tuple_regs_R >= 3) { Sp_adj(-1); Sp(0) = R3; }
+ if(tuple_regs_R >= 2) { Sp_adj(-1); Sp(0) = R2; }
+ if(tuple_regs_R >= 1) { Sp_adj(-1); Sp(0) = R1; }
+
+ /* jump to the BCO that will finish the return of the tuple */
+ Sp_adj(-3);
+ Sp(2) = tuple_info;
+ Sp(1) = tuple_BCO;
+ Sp(0) = stg_ret_t_info;
+
+ jump stg_yield_to_interpreter [];
+}
+
+INFO_TABLE_RET( stg_ret_t, RET_BCO )
+{
+ W_ tuple_info, tuple_stack, tuple_regs_R, tuple_regs_F,
+ tuple_regs_D, tuple_regs_L;
+
+ tuple_info = Sp(2);
+ Sp_adj(3);
+
+ tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */
+ tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */
+ tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */
+ tuple_regs_D = (tuple_info >> 16) & 0x3f; /* 6 bits bitmap */
+ tuple_regs_L = (tuple_info >> 14) & 0x3; /* 2 bits bitmap */
+
+ /* restore everything in the reverse order of stg_ctoi_t */
+
+ /* restore vanilla registers */
+ if(tuple_regs_R >= 1) { R1 = Sp(0); Sp_adj(1); }
+ if(tuple_regs_R >= 2) { R2 = Sp(0); Sp_adj(1); }
+ if(tuple_regs_R >= 3) { R3 = Sp(0); Sp_adj(1); }
+ if(tuple_regs_R >= 4) { R4 = Sp(0); Sp_adj(1); }
+ if(tuple_regs_R >= 5) { R5 = Sp(0); Sp_adj(1); }
+ if(tuple_regs_R >= 6) { R6 = Sp(0); Sp_adj(1); }
+
+ /* restore float registers */
+ if((tuple_regs_F & 1) != 0) { F1 = F_[Sp]; Sp_adj(1); }
+ if((tuple_regs_F & 2) != 0) { F2 = F_[Sp]; Sp_adj(1); }
+ if((tuple_regs_F & 4) != 0) { F3 = F_[Sp]; Sp_adj(1); }
+ if((tuple_regs_F & 8) != 0) { F4 = F_[Sp]; Sp_adj(1); }
+ if((tuple_regs_F & 16) != 0) { F5 = F_[Sp]; Sp_adj(1); }
+ if((tuple_regs_F & 32) != 0) { F6 = F_[Sp]; Sp_adj(1); }
+
+ /* restore double registers */
+ if((tuple_regs_D & 1) != 0) { D1 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+ if((tuple_regs_D & 2) != 0) { D2 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+ if((tuple_regs_D & 4) != 0) { D3 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+ if((tuple_regs_D & 8) != 0) { D4 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+ if((tuple_regs_D & 16) != 0) { D5 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+ if((tuple_regs_D & 32) != 0) { D6 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
+
+ /* restore long registers */
+ if((tuple_regs_L & 1) != 0) { L1 = L_[Sp]; Sp = Sp + 8; }
+
+ /* Sp points to the topmost argument now */
+ jump %ENTRY_CODE(Sp(tuple_stack)) [*]; // NB. all registers live!
+}
+
+
/*
* Dummy info table pushed on the top of the stack when the interpreter
* should apply the BCO on the stack to its arguments, also on the
diff --git a/testsuite/tests/ghci/T16670/T16670_unboxed.hs b/testsuite/tests/ghci/T16670/T16670_unboxed.hs
index 2e903959bba979787bd9e555a13ae25e62720ccc..93816795e01ef8c888063edf0ade933ae295e815 100644
--- a/testsuite/tests/ghci/T16670/T16670_unboxed.hs
+++ b/testsuite/tests/ghci/T16670/T16670_unboxed.hs
@@ -1,5 +1,13 @@
{-# LANGUAGE UnboxedTuples #-}
+
{-# OPTIONS_GHC -fwrite-interface #-}
+{-
+ GHCi doesn't automatically switch to object code anymore now that
+ UnboxedTuples are supported in bytecode. But we test for the
+ existence of the file.
+ -}
+{-# OPTIONS_GHC -fobject-code #-}
+
module T16670_unboxed where
data UnboxedTupleData = MkUTD (# (),() #)
diff --git a/testsuite/tests/ghci/prog014/prog014.T b/testsuite/tests/ghci/prog014/prog014.T
index d9dee7eac7cadb05146ebf572b9e622dc23e2a88..1b583e8c19823a6834abac032266dd6d2b3fadcd 100644
--- a/testsuite/tests/ghci/prog014/prog014.T
+++ b/testsuite/tests/ghci/prog014/prog014.T
@@ -1,5 +1,6 @@
test('prog014',
[extra_files(['Primop.hs', 'dummy.c']),
+ expect_fail, # bytecode compiler doesn't support foreign import prim
extra_run_opts('dummy.o'),
pre_cmd('$MAKE -s --no-print-directory prog014')],
ghci_script, ['prog014.script'])
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
new file mode 100644
index 0000000000000000000000000000000000000000..a1bce35ad0f65732be6f3243d5a44ad9e845cca9
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+#define WW Word64
+#else
+#define WW Word
+#endif
+
+module ByteCode where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
new file mode 100644
index 0000000000000000000000000000000000000000..6931397f093d1ecf3419b71b8b5da36bc3577608
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
@@ -0,0 +1,368 @@
+swap :: (# a, b #) -> (# b, a #)
+swap (# x, y #) = (# y, x #)
+
+type T1 a = a -> (# a #)
+tuple1 :: T1 a
+tuple1 x = (# x #)
+
+tuple1_a :: T1 a -> a -> a
+tuple1_a f x = case f x of (# y #) -> y
+
+tuple1_b :: T1 a -> a -> String -> IO ()
+tuple1_b f x msg = case f x of (# _ #) -> putStrLn msg
+
+-- can still be returned in registers, pointers
+type T2p a = a -> a -> a -> a -> (# a, a, a, a #)
+
+tuple2p :: T2p a
+tuple2p x1 x2 x3 x4 = (# x1, x2, x3, x4 #)
+
+tuple2p_a :: T2p a -> a -> a -> a -> a -> (a, a, a, a)
+tuple2p_a f x1 x2 x3 x4 =
+ case f x1 x2 x3 x4 of (# y1, y2, y3, y4 #) -> (y1, y2, y3, y4)
+
+-- can still be returned in registers, non-pointers
+type T2n = Int -> Int -> Int -> Int -> (# Int#, Int#, Int#, Int# #)
+
+tuple2n :: T2n
+tuple2n (I# x1) (I# x2) (I# x3) (I# x4) = (# x1, x2, x3, x4 #)
+
+tuple2n_a :: T2n -> Int -> Int -> Int -> Int -> (Int, Int, Int, Int)
+tuple2n_a f x1 x2 x3 x4 =
+ case f x1 x2 x3 x4 of
+ (# y1, y2, y3, y4 #) -> (I# y1, I# y2, I# y3, I# y4)
+
+
+-- too big to fit in registers
+type T3 a = a -> a -> a -> a
+ -> a -> a -> a -> a
+ -> a -> a -> a -> a
+ -> (# a, a, a, a
+ , a, a, a, a
+ , a, a, a, a #)
+tuple3 :: T3 a
+tuple3 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
+ (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #)
+
+tuple3_a :: T3 a
+ -> a -> a -> a -> a
+ -> a -> a -> a -> a
+ -> a -> a -> a -> a
+ -> ( a, a, a, a
+ , a, a, a, a
+ , a, a, a, a
+ )
+tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
+ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 of
+ (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12 #) ->
+ (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12)
+
+type T4a = Float -> Double -> Float -> Double
+ -> (# Float#, Double#, Float#, Double# #)
+
+tuple4a :: T4a
+tuple4a (F# f1) (D# d1) (F# f2) (D# d2) = (# f1, d1, f2, d2 #)
+
+tuple4a_a :: T4a
+ -> Float -> Double -> Float -> Double
+ -> (Float, Double, Float, Double)
+tuple4a_a h f1 d1 f2 d2 =
+ case h f1 d1 f2 d2 of (# g1, e1, g2, e2 #) -> (F# g1, D# e1, F# g2, D# e2 )
+
+
+-- this should fill the floating point registers
+type T4b = Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> (# Float#, Double#, Float#, Double#
+ , Float#, Double#, Float#, Double#
+ , Float#, Double#, Float#, Double#
+ , Float#, Double#, Float#, Double#
+ , Float#, Double#, Float#, Double# #)
+tuple4b :: T4b
+tuple4b (F# f1) (D# d1) (F# f2) (D# d2)
+ (F# f3) (D# d3) (F# f4) (D# d4)
+ (F# f5) (D# d5) (F# f6) (D# d6)
+ (F# f7) (D# d7) (F# f8) (D# d8)
+ (F# f9) (D# d9) (F# f10) (D# d10) =
+ (# f1, d1, f2, d2
+ , f3, d3, f4, d4
+ , f5, d5, f6, d6
+ , f7, d7, f8, d8
+ , f9, d9, f10, d10
+ #)
+
+tuple4b_a :: T4b
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> Float -> Double -> Float -> Double
+ -> ( (Float, Double, Float, Double)
+ , (Float, Double, Float, Double)
+ , (Float, Double, Float, Double)
+ , (Float, Double, Float, Double)
+ , (Float, Double, Float, Double)
+ )
+tuple4b_a h f1 d1 f2 d2
+ f3 d3 f4 d4
+ f5 d5 f6 d6
+ f7 d7 f8 d8
+ f9 d9 f10 d10 =
+ case h f1 d1 f2 d2
+ f3 d3 f4 d4
+ f5 d5 f6 d6
+ f7 d7 f8 d8
+ f9 d9 f10 d10 of
+ (# g1, e1, g2, e2
+ , g3, e3, g4, e4
+ , g5, e5, g6, e6
+ , g7, e7, g8, e8
+ , g9, e9, g10, e10 #) ->
+ ( (F# g1, D# e1, F# g2, D# e2)
+ , (F# g3, D# e3, F# g4, D# e4)
+ , (F# g5, D# e5, F# g6, D# e6)
+ , (F# g7, D# e7, F# g8, D# e8)
+ , (F# g9, D# e9, F# g10, D# e10))
+
+type T4c = Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> (# Float#, Double#, WW#, Integer
+ , Float#, Double#, WW#, Integer
+ , Float#, Double#, WW#, Integer
+ , Float#, Double#, WW#, Integer
+ #)
+tuple4c :: T4c
+tuple4c (F# f1) (D# d1) (W64# w1) i1
+ (F# f2) (D# d2) (W64# w2) i2
+ (F# f3) (D# d3) (W64# w3) i3
+ (F# f4) (D# d4) (W64# w4) i4 =
+ (# f1, d1, w1, i1
+ , f2, d2, w2, i2
+ , f3, d3, w3, i3
+ , f4, d4, w4, i4
+ #)
+
+tuple4c_a :: T4c
+ -> Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> Float -> Double -> Word64 -> Integer
+ -> ( ( Float, Double, Word64, Integer)
+ , ( Float, Double, Word64, Integer)
+ , ( Float, Double, Word64, Integer)
+ , ( Float, Double, Word64, Integer)
+ )
+tuple4c_a h f1 d1 w1 i1
+ f2 d2 w2 i2
+ f3 d3 w3 i3
+ f4 d4 w4 i4 =
+ case h f1 d1 w1 i1
+ f2 d2 w2 i2
+ f3 d3 w3 i3
+ f4 d4 w4 i4 of
+ (# f1', d1', w1', i1'
+ , f2', d2', w2', i2'
+ , f3', d3', w3', i3'
+ , f4', d4', w4', i4' #) ->
+ ( (F# f1', D# d1', W64# w1', i1')
+ , (F# f2', D# d2', W64# w2', i2')
+ , (F# f3', D# d3', W64# w3', i3')
+ , (F# f4', D# d4', W64# w4', i4')
+ )
+
+type T5 = Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> (# Int, WW#, Int, WW#
+ , Int, WW#, Int, WW#
+ , Int, WW#, Int, WW#
+ , Int, WW#, Int, WW#
+ #)
+
+tuple5 :: T5
+tuple5 i1 (W64# w1) i2 (W64# w2)
+ i3 (W64# w3) i4 (W64# w4)
+ i5 (W64# w5) i6 (W64# w6)
+ i7 (W64# w7) i8 (W64# w8) =
+ (# i1, w1, i2, w2
+ , i3, w3, i4, w4
+ , i5, w5, i6, w6
+ , i7, w7, i8, w8 #)
+
+tuple5_a :: T5
+ -> Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> Int -> Word64 -> Int -> Word64
+ -> ( (Int, Word64, Int, Word64)
+ , (Int, Word64, Int, Word64)
+ , (Int, Word64, Int, Word64)
+ , (Int, Word64, Int, Word64)
+ )
+tuple5_a f i1 w1 i2 w2
+ i3 w3 i4 w4
+ i5 w5 i6 w6
+ i7 w7 i8 w8 =
+ case f i1 w1 i2 w2
+ i3 w3 i4 w4
+ i5 w5 i6 w6
+ i7 w7 i8 w8 of
+ (# j1, x1, j2, x2
+ , j3, x3, j4, x4
+ , j5, x5, j6, x6
+ , j7, x7, j8, x8
+ #) ->
+ ( (j1, W64# x1, j2, W64# x2)
+ , (j3, W64# x3, j4, W64# x4)
+ , (j5, W64# x5, j6, W64# x6)
+ , (j7, W64# x7, j8, W64# x8)
+ )
+
+type T6 = Int ->
+ (# Int#, (# Int, (# Int#, (# #) #) #) #)
+tuple6 :: T6
+tuple6 x@(I# x#) = (# x#, (# x, (# x#, (# #) #) #) #)
+
+tuple6_a :: T6 -> Int -> String
+tuple6_a f x =
+ case f x of
+ (# x1, (# x2, (# x3, (# #) #) #) #) -> show (I# x1, (x2, (I# x3, ())))
+
+-- empty tuples and tuples with void
+
+type TV1 = Bool -> (# #)
+
+{-# NOINLINE tuple_v1 #-}
+tuple_v1 :: TV1
+tuple_v1 _ = (# #)
+
+{-# NOINLINE tuple_v1_a #-}
+tuple_v1_a :: TV1 -> Bool -> Bool
+tuple_v1_a f x = case f x of (# #) -> True
+
+
+type TV2 = Bool -> (# (# #) #)
+
+{-# NOINLINE tuple_v2 #-}
+tuple_v2 :: TV2
+tuple_v2 _ = (# (# #) #)
+
+{-# NOINLINE tuple_v2_a #-}
+tuple_v2_a :: TV2 -> Bool -> Bool
+tuple_v2_a f x = case f x of (# _ #) -> True
+
+
+type TV3 a = a -> (# (# #), a #)
+
+{-# NOINLINE tuple_v3 #-}
+tuple_v3 :: TV3 a
+tuple_v3 x = (# (# #), x #)
+
+{-# NOINLINE tuple_v3_a #-}
+tuple_v3_a :: TV3 a -> a -> a
+tuple_v3_a f x = case f x of (# _, y #) -> y
+
+
+type TV4 a = a -> (# a, (# #) #)
+
+{-# NOINLINE tuple_v4 #-}
+tuple_v4 :: TV4 a
+tuple_v4 x = (# x, (# #) #)
+
+{-# NOINLINE tuple_v4_a #-}
+tuple_v4_a :: TV4 a -> a -> a
+tuple_v4_a f x = case f x of (# y, _ #) -> y
+
+
+type TV5 a = a -> (# (# #), a, (# #) #)
+
+{-# NOINLINE tuple_v5 #-}
+tuple_v5 :: TV5 a
+tuple_v5 x = (# (# #), x, (# #) #)
+
+{-# NOINLINE tuple_v5_a #-}
+tuple_v5_a :: TV5 a -> a -> a
+tuple_v5_a f x = case f x of (# _, x, _ #) -> x
+
+
+type TV6 = Int -> Double -> Int -> Double
+ -> (# Int#, (# #), Double#, (# #)
+ , Int#, (# #), Double#, (# #) #)
+
+{-# NOINLINE tuple_v6 #-}
+tuple_v6 :: TV6
+tuple_v6 (I# x) (D# y) (I# z) (D# w) = (# x, (# #), y, (# #), z, (# #), w, (# #) #)
+
+{-# NOINLINE tuple_v6_a #-}
+tuple_v6_a :: TV6 -> Int -> Double -> Int -> Double
+ -> (Int, Double, Int, Double)
+tuple_v6_a f x y z w = case f x y z w of (# x', _, y', _, z', _, w', _ #) ->
+ (I# x', D# y', I# z', D# w')
+
+-- some levity polymorphic things
+{-# NOINLINE lev_poly #-}
+lev_poly :: forall r a (b :: TYPE r).
+ (a -> a -> a -> a ->
+ a -> a -> a -> a ->
+ a -> a -> a -> a -> b) -> a -> b
+lev_poly f x = f x x x x x x x x x x x x
+
+{-# NOINLINE lev_poly_a #-}
+lev_poly_a :: (t1
+ -> t2 -> (# a, b, c, d, e, f, g, h, i, j, k, l #))
+ -> t1 -> t2 -> (a, b, c, d, e, f, g, h, i, j, k, l)
+lev_poly_a lp t x =
+ case lp t x of (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #) ->
+ (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+{-# NOINLINE lev_poly_boxed #-}
+lev_poly_boxed x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
+ = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+{-# NOINLINE lev_poly_b #-}
+lev_poly_b lp t x =
+ case lp t x of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+ -> (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+-- some unboxed sums
+type S1 = (# (# Int#, String #) | Bool #)
+
+{-# NOINLINE sum1 #-}
+sum1 :: Int -> Int -> String -> Bool -> S1
+sum1 0 (I# x) y _ = (# (# x, y #) | #)
+sum1 _ _ _ b = (# | b #)
+
+{-# NOINLINE sum1_a #-}
+sum1_a :: (Int -> Int -> String -> Bool -> S1) -> Int -> Int -> String -> Bool -> Either (Int, String) Bool
+sum1_a f n x y b =
+ case f n x y b of
+ (# (# x, y #) | #) -> Left (I# x, y)
+ (# | b #) -> Right b
+
+
+type S2 a = (# (# a, a, a, a #) | (# a, a #) | (# #) | Int# | Int #)
+
+{-# NOINLINE sum2 #-}
+sum2 :: Int -> a -> S2 a
+sum2 0 x = (# (# x, x, x, x #) | | | | #)
+sum2 1 x = (# | (# x, x #) | | | #)
+sum2 2 _ = (# | | (# #) | | #)
+sum2 n@(I# n#) _
+ | even n = (# | | | n# | #)
+ | otherwise = (# | | | | n #)
+
+{-# NOINLINE sum2_a #-}
+sum2_a :: Show a => (Int -> a -> S2 a) -> Int -> a -> String
+sum2_a f n x =
+ case f n x of
+ (# (# x1, x2, x3, x4 #) | | | | #) -> show (x1, x2, x3, x4)
+ (# | (# x1, x2 #) | | | #) -> show (x1, x2)
+ (# | | (# #) | | #) -> "(# #)"
+ (# | | | x# | #) -> show (I# x#) ++ "#"
+ (# | | | | x #) -> show x
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
new file mode 100644
index 0000000000000000000000000000000000000000..190b8f1683e104a04159c647f6229a910a137349
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
+{-# OPTIONS_GHC -fobject-code #-}
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+#define WW Word64
+#else
+#define WW Word
+#endif
+
+module Obj where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
new file mode 100644
index 0000000000000000000000000000000000000000..1daec7f2079f9ad7a453106e9a0f03903bfd2fb1
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+{-
+ Test unboxed tuples and sums in the bytecode interpreter.
+
+ The bytecode interpreter uses the stack for everything, while
+ compiled code uses STG registers for arguments and return values.
+ -}
+
+module Main where
+
+import qualified Obj as O
+import qualified ByteCode as B
+
+import GHC.Exts
+import GHC.Word
+
+main :: IO ()
+main = do
+
+ case B.swap (O.swap (B.swap (O.swap (# "x", 1 #)))) of
+ (# y1, y2 #) -> print (y1, y2)
+
+ -- one-tuples
+ testX "tuple1"
+ B.tuple1_a O.tuple1_a
+ B.tuple1 O.tuple1
+ (\f -> f 90053)
+
+ -- check that the contents of a one-tuple aren't evaluated
+ B.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
+ B.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
+ O.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
+ O.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
+
+ -- various size tuples with boxed/unboxed elements
+ testX "tuple2p"
+ B.tuple2p_a O.tuple2p_a
+ B.tuple2p O.tuple2p
+ (\f -> f (1234::Integer) 1235 1236 1237)
+
+ testX "tuple2n"
+ B.tuple2n_a O.tuple2n_a
+ B.tuple2n O.tuple2n
+ (\f -> f 7654 7653 7652 7651)
+
+ testX "tuple3"
+ B.tuple3_a O.tuple3_a
+ B.tuple3 O.tuple3
+ (\f -> f (1000::Integer) 1001 1002 1003
+ 1004 1005 1006 1007
+ 1008 1009 1010 1011)
+
+ testX "tuple4a"
+ B.tuple4a_a O.tuple4a_a
+ B.tuple4a O.tuple4a
+ (\f -> f 2000 2001 2002 2003)
+
+ testX "tuple4b"
+ B.tuple4b_a O.tuple4b_a
+ B.tuple4b O.tuple4b
+ (\f -> f 3000 3001 3002 3003
+ 3004 3005 3006 3007
+ 3008 3009 3010 3011
+ 3012 3013 3014 3015
+ 3016 3017 3018 3019)
+
+ testX "tuple4c"
+ B.tuple4c_a O.tuple4c_a
+ B.tuple4c O.tuple4c
+ (\f -> f 3000 3001 3002 3003
+ 3004 3005 3006 3007
+ 3008 3009 3010 3011
+ 3012 3013 3014 3015)
+
+ testX "tuple5"
+ B.tuple5_a O.tuple5_a
+ B.tuple5 O.tuple5
+ (\f -> f 4000 4001 4002 4003
+ 4004 4005 4006 4007
+ 4008 4009 4010 4011
+ 4012 4013 4014 4015)
+
+ testX "tuple6"
+ B.tuple6_a O.tuple6_a
+ B.tuple6 O.tuple6
+ (\f -> f 6006)
+
+ -- tuples with void and empty tuples
+ testX "tuplev1"
+ B.tuple_v1_a O.tuple_v1_a
+ B.tuple_v1 O.tuple_v1
+ (\f -> f False)
+
+ testX "tuplev2"
+ B.tuple_v2_a O.tuple_v2_a
+ B.tuple_v2 O.tuple_v2
+ (\f -> f False)
+
+ testX "tuplev3"
+ B.tuple_v3_a O.tuple_v3_a
+ B.tuple_v3 O.tuple_v3
+ (\f -> f 30001)
+
+ testX "tuplev4"
+ B.tuple_v4_a O.tuple_v4_a
+ B.tuple_v4 O.tuple_v4
+ (\f -> f 40001)
+
+ testX "tuplev5"
+ B.tuple_v5_a O.tuple_v5_a
+ B.tuple_v5 O.tuple_v5
+ (\f -> f 50001)
+
+ testX "tuplev6"
+ B.tuple_v6_a O.tuple_v6_a
+ B.tuple_v6 O.tuple_v6
+ (\f -> f 601 602 603 604)
+
+ -- levity polymorphic
+ print $ B.lev_poly_a B.lev_poly B.tuple3 991
+ print $ B.lev_poly_a B.lev_poly O.tuple3 992
+ print $ B.lev_poly_a O.lev_poly B.tuple3 993
+ print $ B.lev_poly_a O.lev_poly O.tuple3 994
+ print $ O.lev_poly_a B.lev_poly B.tuple3 995
+ print $ O.lev_poly_a B.lev_poly O.tuple3 996
+ print $ O.lev_poly_a O.lev_poly B.tuple3 997
+ print $ O.lev_poly_a O.lev_poly O.tuple3 998
+
+ print $ B.lev_poly_b B.lev_poly B.lev_poly_boxed 981
+ print $ B.lev_poly_b B.lev_poly O.lev_poly_boxed 982
+ print $ B.lev_poly_b O.lev_poly B.lev_poly_boxed 983
+ print $ B.lev_poly_b O.lev_poly O.lev_poly_boxed 984
+ print $ O.lev_poly_b B.lev_poly B.lev_poly_boxed 985
+ print $ O.lev_poly_b B.lev_poly O.lev_poly_boxed 986
+ print $ O.lev_poly_b O.lev_poly B.lev_poly_boxed 987
+ print $ O.lev_poly_b O.lev_poly O.lev_poly_boxed 988
+
+ -- sums
+ testX "sum1a"
+ B.sum1_a O.sum1_a
+ B.sum1 O.sum1
+ (\f -> f 0 1 "23" True)
+
+ testX "sum1b"
+ B.sum1_a O.sum1_a
+ B.sum1 O.sum1
+ (\f -> f 1 1 "23" True)
+
+ testX "sum2a"
+ B.sum2_a O.sum2_a
+ B.sum2 O.sum2
+ (\f -> f 0 "sum2")
+
+ testX "sum2b"
+ B.sum2_a O.sum2_a
+ B.sum2 O.sum2
+ (\f -> f 1 "sum2")
+
+ testX "sum2c"
+ B.sum2_a O.sum2_a
+ B.sum2 O.sum2
+ (\f -> f 2 "sum2")
+
+ testX "sum2d"
+ B.sum2_a O.sum2_a
+ B.sum2 O.sum2
+ (\f -> f 3 "sum2")
+
+ testX "sum2e"
+ B.sum2_a O.sum2_a
+ B.sum2 O.sum2
+ (\f -> f 4 "sum2")
+
+
+
+testX :: (Eq a, Show a)
+ => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
+testX msg a1 a2 b1 b2 ap =
+ let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
+ in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..82619b86fcbd21829206a84f8005a2042da6e70b
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
@@ -0,0 +1,43 @@
+("x",1)
+tuple1 True 90053
+tuple1_b
+tuple1_b
+tuple1_b
+tuple1_b
+tuple2p True (1234,1235,1236,1237)
+tuple2n True (7654,7653,7652,7651)
+tuple3 True (1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011)
+tuple4a True (2000.0,2001.0,2002.0,2003.0)
+tuple4b True ((3000.0,3001.0,3002.0,3003.0),(3004.0,3005.0,3006.0,3007.0),(3008.0,3009.0,3010.0,3011.0),(3012.0,3013.0,3014.0,3015.0),(3016.0,3017.0,3018.0,3019.0))
+tuple4c True ((3000.0,3001.0,3002,3003),(3004.0,3005.0,3006,3007),(3008.0,3009.0,3010,3011),(3012.0,3013.0,3014,3015))
+tuple5 True ((4000,4001,4002,4003),(4004,4005,4006,4007),(4008,4009,4010,4011),(4012,4013,4014,4015))
+tuple6 True "(6006,(6006,(6006,())))"
+tuplev1 True True
+tuplev2 True True
+tuplev3 True 30001
+tuplev4 True 40001
+tuplev5 True 50001
+tuplev6 True (601,602.0,603,604.0)
+(991,991,991,991,991,991,991,991,991,991,991,991)
+(992,992,992,992,992,992,992,992,992,992,992,992)
+(993,993,993,993,993,993,993,993,993,993,993,993)
+(994,994,994,994,994,994,994,994,994,994,994,994)
+(995,995,995,995,995,995,995,995,995,995,995,995)
+(996,996,996,996,996,996,996,996,996,996,996,996)
+(997,997,997,997,997,997,997,997,997,997,997,997)
+(998,998,998,998,998,998,998,998,998,998,998,998)
+(981,981,981,981,981,981,981,981,981,981,981,981)
+(982,982,982,982,982,982,982,982,982,982,982,982)
+(983,983,983,983,983,983,983,983,983,983,983,983)
+(984,984,984,984,984,984,984,984,984,984,984,984)
+(985,985,985,985,985,985,985,985,985,985,985,985)
+(986,986,986,986,986,986,986,986,986,986,986,986)
+(987,987,987,987,987,987,987,987,987,987,987,987)
+(988,988,988,988,988,988,988,988,988,988,988,988)
+sum1a True Left (1,"23")
+sum1b True Right True
+sum2a True "(\"sum2\",\"sum2\",\"sum2\",\"sum2\")"
+sum2b True "(\"sum2\",\"sum2\")"
+sum2c True "(# #)"
+sum2d True "3"
+sum2e True "4#"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
new file mode 100644
index 0000000000000000000000000000000000000000..4166c82f7fe2c3bbfdd1a28a6d49b8b7e421fc76
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
@@ -0,0 +1,10 @@
+test('UnboxedTuples',
+ [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']),
+ req_interp,
+ extra_ways(['ghci']),
+ when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])),
+ when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof']))
+ ],
+ compile_and_run,
+ ['']
+ )