@@ -0,0 +1,1539 @@
1+diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
2+index 44876efc91..8b0fb9a17e 100644
3+--- a/compiler/ghci/ByteCodeAsm.hs
4++++ b/compiler/ghci/ByteCodeAsm.hs
5+@@ -7,10 +7,10 @@
6+ -- | ByteCodeLink: Bytecode assembler and linker
7+ module ByteCodeAsm (
8+ assembleBCOs, assembleOneBCO,
9+-
10+ bcoFreeNames,
11+ SizedSeq, sizeSS, ssElts,
12+- iNTERP_STACK_CHECK_THRESH
13++ iNTERP_STACK_CHECK_THRESH,
14++ mkTupleInfoSig
15+ ) where
16+
17+ #include "HsVersions.h"
18+@@ -376,6 +376,16 @@ assembleI dflags i = case i of
19+ -> do let ul_bco = assembleBCO dflags proto
20+ p <- ioptr (liftM BCOPtrBCO ul_bco)
21+ emit (push_alts pk) [Op p]
22++ PUSH_ALTS_T proto tuple_info tuple_proto
23++ -> do let ul_bco = assembleBCO dflags proto
24++ ul_tuple_bco = assembleBCO dflags
25++ tuple_proto
26++ p <- ioptr (liftM BCOPtrBCO ul_bco)
27++ p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
28++ info <- int (fromIntegral $
29++ mkTupleInfoSig tuple_info)
30++ emit bci_PUSH_ALTS_T
31++ [Op p, Op info, Op p_tup]
32+ PUSH_PAD8 -> emit bci_PUSH_PAD8 []
33+ PUSH_PAD16 -> emit bci_PUSH_PAD16 []
34+ PUSH_PAD32 -> emit bci_PUSH_PAD32 []
35+@@ -434,6 +444,7 @@ assembleI dflags i = case i of
36+ ENTER -> emit bci_ENTER []
37+ RETURN -> emit bci_RETURN []
38+ RETURN_UBX rep -> emit (return_ubx rep) []
39++ RETURN_T -> emit bci_RETURN_T []
40+ CCALL off m_addr i -> do np <- addr m_addr
41+ emit bci_CCALL [SmallOp off, Op np, SmallOp i]
42+ BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
43+@@ -501,6 +512,41 @@ return_ubx V16 = error "return_ubx: vector"
44+ return_ubx V32 = error "return_ubx: vector"
45+ return_ubx V64 = error "return_ubx: vector"
46+
47++{-
48++ Construct the tuple_info word that stg_ctoi_t and stg_ret_t use
49++ to convert a tuple between the native calling convention and the
50++ interpreter.
51++
52++ See StgMiscClosures.cmm for more information.
53++ -}
54++mkTupleInfoSig :: TupleInfo -> Word32
55++mkTupleInfoSig ti@TupleInfo{..}
56++ {-
57++ we can only handle up to a fixed number of words on the stack,
58++ because we need a stg_ctoi_tN stack frame for each size N
59++
60++ If needed, you can support larger tuples by adding more in
61++ StgMiscClosures.cmm and MiscClosures.h
62++ -}
63++ | tupleNativeStackSize > 32 =
64++ pprPanic "mkTupleInfoSig: tuple too big" (ppr tupleNativeStackSize)
65++ | tupleNativeStackSize < 16384 &&
66++ tupleDoubleRegs < 64 && -- 6 bit bitmap (these can be shared with float)
67++ tupleFloatRegs < 64 && -- 6 bit bitmap (these can be shared with double)
68++ tupleLongRegs < 4 && -- 2 bit bitmap
69++ tupleVanillaRegs < 65536 && -- 4 bit count
70++ -- check that there are no "holes", i.e. that R1..Rn are all in use
71++ tupleVanillaRegs .&. (tupleVanillaRegs + 1) == 0
72++ = fromIntegral tupleNativeStackSize .|.
73++ w (tupleLongRegs `shiftL` 14) .|.
74++ w (tupleDoubleRegs `shiftL` 16) .|.
75++ w (tupleFloatRegs `shiftL` 22) .|.
76++ w (countTrailingZeros (1 + tupleVanillaRegs) `shiftL` 28)
77++ | otherwise = pprPanic "mkTupleInfoSig: unsupported tuple shape" (ppr ti)
78++ where
79++ w :: Int -> Word32
80++ w = fromIntegral
81++
82+ -- Make lists of host-sized words for literals, so that when the
83+ -- words are placed in memory at increasing addresses, the
84+ -- bit pattern is correct for the host's word size and endianness.
85+diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
86+index fb60c21f9d..62e8457c5a 100644
87+--- a/compiler/ghci/ByteCodeGen.hs
88++++ b/compiler/ghci/ByteCodeGen.hs
89+@@ -17,6 +17,11 @@ import ByteCodeInstr
90+ import ByteCodeAsm
91+ import ByteCodeTypes
92+
93++import CmmCallConv
94++import CmmExpr
95++import CmmNode
96++import CmmUtils
97++
98+ import GHCi
99+ import GHCi.FFI
100+ import GHCi.RemoteTypes
101+@@ -195,12 +200,6 @@ simpleFreeVars = freeVars
102+
103+ type BCInstrList = OrdList BCInstr
104+
105+-newtype ByteOff = ByteOff Int
106+- deriving (Enum, Eq, Integral, Num, Ord, Real)
107+-
108+-newtype WordOff = WordOff Int
109+- deriving (Enum, Eq, Integral, Num, Ord, Real)
110+-
111+ wordsToBytes :: DynFlags -> WordOff -> ByteOff
112+ wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
113+
114+@@ -230,7 +229,7 @@ ppBCEnv p
115+ $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
116+ $$ text "end-env"
117+ where
118+- pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
119++ pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
120+ cmp_snd x y = compare (snd x) (snd y)
121+ -}
122+
123+@@ -299,6 +298,11 @@ argBits dflags (rep : args)
124+ | isFollowableArg rep = False : argBits dflags args
125+ | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
126+
127++non_void :: [ArgRep] -> [ArgRep]
128++non_void = filter nv
129++ where nv V = False
130++ nv _ = True
131++
132+ -- -----------------------------------------------------------------------------
133+ -- schemeTopBind
134+
135+@@ -482,6 +486,57 @@ returnUnboxedAtom d s p e e_rep = do
136+ `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
137+ `snocOL` RETURN_UBX e_rep) -- go
138+
139++-- XXX merge the two functions below
140++-- XXX use the old special cases if possible (more efficient)
141++returnUnboxedTuple
142++ :: StackDepth
143++ -> Sequel
144++ -> BCEnv
145++ -> [AnnExpr' Id DVarSet]
146++ -> BcM BCInstrList
147++returnUnboxedTuple d s p es = do
148++ dflags <- getDynFlags
149++ let arg_ty e = primRepCmmType dflags (atomPrimRep e)
150++ (tuple_info, tuple_components) = layoutTuple dflags d arg_ty es
151++ args_ptrs = map (\(e, off) -> (isFollowableArg (atomRep e), off)) tuple_components
152++ go _ pushes [] = return (reverse pushes)
153++ go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
154++ MASSERT(off == dd + szb)
155++ go (dd + szb) (push:pushes) cs
156++ pushes <- go d [] tuple_components
157++ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
158++ return (mconcat pushes
159++ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel
160++ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word
161++ `snocOL` PUSH_BCO tuple_bco -- add info BCO
162++ `snocOL` RETURN_T) -- go
163++
164++
165++
166++-- return a tuple that's already on the stack in the right order
167++returnUnboxedTuple'
168++ :: StackDepth -- ^ current stack depth
169++ -> Sequel -- ^ depth of sequel
170++ -> BCEnv
171++ -> StackDepth -- ^ depth of start of tuple
172++ -> [PrimRep]
173++ -> BcM BCInstrList
174++returnUnboxedTuple' d s _p d_tuple t_reps = do
175++ dflags <- getDynFlags
176++ let arg_ty :: PrimRep -> CmmType
177++ arg_ty e = primRepCmmType dflags e
178++ (tuple_info, tuple_components) = layoutTuple dflags d arg_ty t_reps
179++ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) tuple_components
180++ tuple_offset = trunc16W $ bytesToWords dflags (d - d_tuple) + tupleSize tuple_info - 1
181++ copyTuple = replicate (fromIntegral $ tupleSize tuple_info)
182++ (PUSH_L tuple_offset)
183++ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
184++ return (toOL copyTuple
185++ `appOL` mkSlideB dflags (wordsToBytes dflags $ tupleSize tuple_info) (d - s) -- clear to sequel
186++ `snocOL` PUSH_UBX (mkLitWord dflags . fromIntegral $ mkTupleInfoSig tuple_info) 1 -- add info word
187++ `snocOL` PUSH_BCO tuple_bco
188++ `snocOL` RETURN_T) -- go
189++
190+ -- Compile code to apply the given expression to the remaining args
191+ -- on the stack, returning a HNF.
192+ schemeE
193+@@ -499,6 +554,10 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
194+ schemeE d s p e@(AnnVar v)
195+ -- See Note [Not-necessarily-lifted join points], step 3.
196+ | isNNLJoinPoint v = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
197++ | isUnboxedTupleType (idType v) =
198++ let d_tuple = fromMaybe (panic "CoreToByteCode.schemeE: global unboxed tuples are not supported")
199++ (lookupBCEnv_maybe v p)
200++ in returnUnboxedTuple' d s p d_tuple (bcIdPrimReps v) --- XXX should this be arg reps instead?
201+ | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
202+ | otherwise = schemeT d s p e
203+
204+@@ -817,7 +876,8 @@ schemeT d s p app
205+ unboxedTupleReturn d s p arg2
206+ [arg1,arg2] | isVAtom arg2 ->
207+ unboxedTupleReturn d s p arg1
208+- _other -> multiValException
209++ -- XXX find if we can work the above cases into the general version
210++ other -> returnUnboxedTuple d s p (reverse other)
211+
212+ -- Case 3: Ordinary data constructor
213+ | Just con <- maybe_saturated_dcon
214+@@ -979,12 +1039,12 @@ doCase
215+ -- don't enter the result
216+ -> BcM BCInstrList
217+ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
218+- | typePrimRep (idType bndr) `lengthExceeds` 1
219+- = multiValException
220+- | otherwise
221+ = do
222+ dflags <- getDynFlags
223+ let
224++ -- XXX handle general unboxed tuples and the old special cased ones properly here
225++ utup = isUnboxedTupleType bndr_ty && length (non_void (typeArgReps bndr_ty)) > 1
226++
227+ profiling
228+ | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
229+ | otherwise = rtsIsProfiled
230+@@ -994,8 +1054,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
231+ -- When an alt is entered, it assumes the returned value is
232+ -- on top of the itbl.
233+ ret_frame_size_b :: StackDepth
234+- ret_frame_size_b = 2 * wordSize dflags
235+-
236++ ret_frame_size_b | utup = 4 * wordSize dflags
237++ | otherwise = 2 * wordSize dflags
238++
239+ -- The extra frame we push to save/restor the CCCS when profiling
240+ save_ccs_size_b | profiling = 2 * wordSize dflags
241+ | otherwise = 0
242+@@ -1004,16 +1065,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
243+ -- when it is returned.
244+ unlifted_itbl_size_b :: StackDepth
245+ unlifted_itbl_size_b | isAlgCase = 0
246+- | otherwise = wordSize dflags
247++ | utup = 3 * wordSize dflags
248++ | otherwise = wordSize dflags
249++
250++ bndr_size | utup = let bndr_ty = primRepCmmType dflags
251++ (tuple_info, _) = layoutTuple dflags 0 bndr_ty (bcIdPrimReps bndr)
252++ in wordsToBytes dflags (tupleSize tuple_info)
253++ | otherwise = wordsToBytes dflags (idSizeW dflags bndr)
254+
255+ -- depth of stack after the return value has been pushed
256+ d_bndr =
257+- d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
258++ d + ret_frame_size_b + bndr_size
259+
260+ -- depth of stack after the extra info table for an unboxed return
261+ -- has been pushed, if any. This is the stack depth at the
262+ -- continuation.
263+- d_alts = d_bndr + unlifted_itbl_size_b
264++ d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
265+
266+ -- Env in which to compile the alts, not including
267+ -- any vars bound by the alts themselves
268+@@ -1036,11 +1103,26 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
269+ | null real_bndrs = do
270+ rhs_code <- schemeE d_alts s p_alts rhs
271+ return (my_discr alt, rhs_code)
272+- -- If an alt attempts to match on an unboxed tuple or sum, we must
273+- -- bail out, as the bytecode compiler can't handle them.
274+- -- (See #14608.)
275+- | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
276+- = multiValException
277++ | utup =
278++ let bndr_ty = primRepCmmType dflags . bcIdPrimRep
279++ tuple_start = d_bndr
280++ (tuple_info, args_offsets) =
281++ layoutTuple dflags
282++ 0
283++ bndr_ty
284++ bndrs
285++
286++ stack_bot = d_alts
287++
288++ p' = Map.insertList
289++ [ (arg, tuple_start - wordsToBytes dflags (tupleSize tuple_info) + offset)
290++ | (arg, offset) <- args_offsets
291++ , not (isVoidRep $ bcIdPrimRep arg)]
292++ p_alts
293++ in do
294++ -- traceCBC ("ubx tup cont: " ++ show (stack_bot,tuple_start,tot_wds) ++ "\n" ++ show args_offsets)
295++ rhs_code <- schemeE stack_bot s p' rhs
296++ return (NoDiscr, rhs_code)
297+ -- algebraic alt with some binders
298+ | otherwise =
299+ let (tot_wds, _ptrs_wds, args_offsets) =
300+@@ -1068,7 +1150,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
301+ my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
302+ my_discr (DataAlt dc, _, _)
303+ | isUnboxedTupleCon dc || isUnboxedSumCon dc
304+- = multiValException
305++ = NoDiscr
306+ | otherwise
307+ = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
308+ my_discr (LitAlt l, _, _)
309+@@ -1100,17 +1182,22 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
310+ -- really want a bitmap up to depth (d-s). This affects compilation of
311+ -- case-of-case expressions, which is the only time we can be compiling a
312+ -- case expression with s /= 0.
313+- bitmap_size = trunc16W $ bytesToWords dflags (d - s)
314++ bitmap_size | utup = trunc16W $ 2 + bytesToWords dflags (d - s)
315++ | otherwise = trunc16W $ bytesToWords dflags (d - s)
316+ bitmap_size' :: Int
317+ bitmap_size' = fromIntegral bitmap_size
318+- bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
319+- (sort (filter (< bitmap_size') rel_slots))
320++ -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
321++ bitmap | utup = intsToReverseBitmap dflags bitmap_size'{-size-}
322++ (1 : sort (filter (< bitmap_size') (map (+2) rel_slots)))
323++ | otherwise = intsToReverseBitmap dflags bitmap_size'{-size-}
324++ (sort (filter (< bitmap_size') rel_slots))
325+ where
326+ binds = Map.toList p
327+ -- NB: unboxed tuple cases bind the scrut binder to the same offset
328+ -- as one of the alt binders, so we have to remove any duplicates here:
329+ rel_slots = nub $ map fromIntegral $ concat (map spread binds)
330+- spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
331++ spread (id, offset) | isUnboxedTupleType (idType id) = []
332++ | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
333+ | otherwise = []
334+ where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
335+
336+@@ -1121,19 +1208,117 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
337+ alt_bco_name = getName bndr
338+ alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
339+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
340+--- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
341+--- "\n bitmap = " ++ show bitmap) $ do
342+-
343+ scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
344+ (d + ret_frame_size_b + save_ccs_size_b)
345+ p scrut
346+ alt_bco' <- emitBc alt_bco
347+- let push_alts
348+- | isAlgCase = PUSH_ALTS alt_bco'
349+- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
350+- return (push_alts `consOL` scrut_code)
351++ if utup
352++ then do
353++ -- XXX we shouldn't call layoutTuple twice
354++ let (tuple_info, args_offsets) =
355++ layoutTuple dflags
356++ 0
357++ (primRepCmmType dflags)
358++ (bcIdPrimReps bndr)
359++ args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep rep), off)) args_offsets
360++ tuple_bco <- emitBc (tupleBCO dflags tuple_info args_ptrs)
361++ return (PUSH_ALTS_T alt_bco' tuple_info tuple_bco
362++ `consOL` scrut_code)
363++ else let push_alts
364++ | isAlgCase = PUSH_ALTS alt_bco'
365++ | otherwise = PUSH_ALTS_UNLIFTED alt_bco'
366++ (typeArgRep bndr_ty)
367++ in return (push_alts `consOL` scrut_code)
368+
369+
370++-- -----------------------------------------------------------------------------
371++-- Deal with tuples
372++
373++-- The native calling convention uses registers for tuples, but in the
374++-- bytecode interpreter, all values live on the stack.
375++
376++layoutTuple :: DynFlags
377++ -> ByteOff
378++ -> (a -> CmmType)
379++ -> [a]
380++ -> ( TupleInfo
381++ , [(a, ByteOff)] -- argument, offset on stack
382++ )
383++layoutTuple dflags start_off arg_ty reps =
384++ let (orig_stk_bytes, pos) = assignArgumentsPos dflags
385++ 0
386++ NativeReturn
387++ arg_ty
388++ reps
389++
390++ -- keep the stack parameters in the same place
391++ orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]
392++
393++ -- sort the register parameters by register and add them to the stack
394++ (regs, reg_params)
395++ = unzip $ sortBy (comparing fst)
396++ [(reg, x) | (x, RegisterParam reg) <- pos]
397++
398++ (new_stk_bytes, new_stk_params) = assignStack dflags
399++ orig_stk_bytes
400++ arg_ty
401++ reg_params
402++
403++ -- make live register bitmaps
404++ bmp_reg r ~(v, f, d, l)
405++ = case r of VanillaReg n _ -> (a v n, f, d, l )
406++ FloatReg n -> (v, a f n, d, l )
407++ DoubleReg n -> (v, f, a d n, l )
408++ LongReg n -> (v, f, d, a l n)
409++ _ ->
410++ pprPanic "CoreToByteCode.layoutTuple count_reg"
411++ (ppr r)
412++ where a bmp n = bmp .|. (1 `shiftL` (n-1))
413++
414++ (vanilla_regs, float_regs, double_regs, long_regs)
415++ = foldr bmp_reg (0, 0, 0, 0) regs
416++
417++ get_byte_off (x, StackParam y) = (x, fromIntegral y)
418++ get_byte_off _ =
419++ panic "CoreToByteCode.layoutTuple get_byte_off"
420++
421++ in ( TupleInfo
422++ { tupleSize = bytesToWords dflags (ByteOff new_stk_bytes)
423++ , tupleVanillaRegs = vanilla_regs
424++ , tupleLongRegs = long_regs
425++ , tupleFloatRegs = float_regs
426++ , tupleDoubleRegs = double_regs
427++ , tupleNativeStackSize = bytesToWords dflags
428++ (ByteOff orig_stk_bytes)
429++ }
430++ , sortBy (comparing snd) $
431++ map (\(x, o) -> (x, o + start_off))
432++ (orig_stk_params ++ map get_byte_off new_stk_params)
433++ )
434++
435++tupleBCO :: DynFlags -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
436++tupleBCO dflags info pointers =
437++ mkProtoBCO dflags invented_name body_code (Left [])
438++ 0{-no arity-} bitmap_size bitmap False{-is alts-}
439++
440++ where
441++ {-
442++ The tuple BCO is never referred to by name, so we can get away
443++ with using a fake name here. We will need to change this if we want
444++ to save some memory by sharing the BCO between places that have
445++ the same tuple shape
446++ -}
447++ invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
448++
449++ -- the first word in the frame is the tuple_info word,
450++ -- which is not a pointer
451++ bitmap_size = trunc16W $ 1 + tupleSize info
452++ bitmap = intsToReverseBitmap dflags (fromIntegral bitmap_size) $
453++ map ((+1) . fromIntegral . bytesToWords dflags . snd)
454++ (filter fst pointers)
455++ body_code = mkSlideW 0 1 -- pop frame header
456++ `snocOL` RETURN_T -- and add it again
457++
458+ -- -----------------------------------------------------------------------------
459+ -- Deal with a CCall.
460+
461+@@ -1814,6 +1999,9 @@ bcIdPrimRep id
462+ | otherwise
463+ = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
464+
465++bcIdPrimReps :: Id -> [PrimRep]
466++bcIdPrimReps id = typePrimRepArgs (idType id)
467++
468+ repSizeWords :: DynFlags -> PrimRep -> WordOff
469+ repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
470+
471+@@ -1921,6 +2109,10 @@ mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
472+ typeArgRep :: Type -> ArgRep
473+ typeArgRep = toArgRep . typePrimRep1
474+
475++-- XXX this can be removed?
476++typeArgReps :: Type -> [ArgRep]
477++typeArgReps = map toArgRep . typePrimRepArgs -- typePrimRepArgs (idType id)
478++
479+ -- -----------------------------------------------------------------------------
480+ -- The bytecode generator's monad
481+
482+diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
483+index c386ece52a..d8f902546f 100644
484+--- a/compiler/ghci/ByteCodeInstr.hs
485++++ b/compiler/ghci/ByteCodeInstr.hs
486+@@ -86,6 +86,9 @@ data BCInstr
487+ -- Push an alt continuation
488+ | PUSH_ALTS (ProtoBCO Name)
489+ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
490++ | PUSH_ALTS_T (ProtoBCO Name) -- continuation
491++ !TupleInfo
492++ (ProtoBCO Name) -- tuple return BCO
493+
494+ -- Pushing 8, 16 and 32 bits of padding (for constructors).
495+ | PUSH_PAD8
496+@@ -168,8 +171,9 @@ data BCInstr
497+
498+ -- To Infinity And Beyond
499+ | ENTER
500+- | RETURN -- return a lifted value
501++ | RETURN -- return a lifted value
502+ | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
503++ | RETURN_T -- return an unboxed tuple (info already on stack)
504+
505+ -- Breakpoints
506+ | BRK_FUN Word16 Unique (RemotePtr CostCentre)
507+@@ -234,8 +238,13 @@ instance Outputable BCInstr where
508+ ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
509+ <> ppr op
510+ ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
511++
512+ ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
513+ ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
514++ ppr (PUSH_ALTS_T bco tuple_info tuple_bco) =
515++ hang (text "PUSH_ALTS_T" <+> ppr tuple_info)
516++ 2
517++ (ppr tuple_bco $+$ ppr bco)
518+
519+ ppr PUSH_PAD8 = text "PUSH_PAD8"
520+ ppr PUSH_PAD16 = text "PUSH_PAD16"
521+@@ -292,8 +301,11 @@ instance Outputable BCInstr where
522+ ppr ENTER = text "ENTER"
523+ ppr RETURN = text "RETURN"
524+ ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
525++ ppr (RETURN_T) = text "RETURN_T"
526+ ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
527+
528++
529++
530+ -- -----------------------------------------------------------------------------
531+ -- The stack use, in words, of each bytecode insn. These _must_ be
532+ -- correct, or overestimates of reality, to be safe.
533+@@ -321,8 +333,14 @@ bciStackUse PUSH32_W{} = 1 -- takes exactly 1 word
534+ bciStackUse PUSH_G{} = 1
535+ bciStackUse PUSH_PRIMOP{} = 1
536+ bciStackUse PUSH_BCO{} = 1
537+-bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
538+-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
539++-- XXX these don't take stack space for restoring the CCCS into account!
540++bciStackUse (PUSH_ALTS bco) = 3 + protoBCOStackUse bco
541++bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 4 + protoBCOStackUse bco
542++bciStackUse (PUSH_ALTS_T bco info _) =
543++ -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)
544++ -- tuple
545++ -- (tuple_info, tuple_bco, stg_ret_t)
546++ 7 + fromIntegral (tupleSize info) + protoBCOStackUse bco
547+ bciStackUse (PUSH_PAD8) = 1 -- overapproximation
548+ bciStackUse (PUSH_PAD16) = 1 -- overapproximation
549+ bciStackUse (PUSH_PAD32) = 1 -- overapproximation on 64bit arch
550+@@ -361,6 +379,7 @@ bciStackUse JMP{} = 0
551+ bciStackUse ENTER{} = 0
552+ bciStackUse RETURN{} = 0
553+ bciStackUse RETURN_UBX{} = 1
554++bciStackUse RETURN_T{} = 1
555+ bciStackUse CCALL{} = 0
556+ bciStackUse SWIZZLE{} = 0
557+ bciStackUse BRK_FUN{} = 0
558+diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs
559+index 0c0c34ad64..71378b27f3 100644
560+--- a/compiler/ghci/ByteCodeTypes.hs
561++++ b/compiler/ghci/ByteCodeTypes.hs
562+@@ -8,6 +8,8 @@ module ByteCodeTypes
563+ ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)
564+ , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)
565+ , ItblEnv, ItblPtr(..)
566++ , TupleInfo(..)
567++ , ByteOff(..), WordOff(..)
568+ , CgBreakInfo(..)
569+ , ModBreaks (..), BreakIndex, emptyModBreaks
570+ , CCostCentre
571+@@ -67,6 +69,34 @@ seqCompiledByteCode CompiledByteCode{..} =
572+ rnf bc_strs `seq`
573+ rnf (fmap seqModBreaks bc_breaks)
574+
575++newtype ByteOff = ByteOff Int
576++ deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)
577++
578++newtype WordOff = WordOff Int
579++ deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)
580++
581++-- This contains the data we need for passing unboxed tuples between
582++-- bytecode and native code
583++data TupleInfo = TupleInfo
584++ { tupleSize :: !WordOff -- total size of tuple in words
585++ , tupleVanillaRegs :: !Int -- vanilla registers used (bitmap)
586++ , tupleLongRegs :: !Int -- long registers used (bitmap)
587++ , tupleFloatRegs :: !Int -- float registers used (bitmap)
588++ , tupleDoubleRegs :: !Int -- double registers used (bitmap)
589++ , tupleNativeStackSize :: !WordOff {- words spilled on the stack by
590++ native calling convention -}
591++ } deriving (Show)
592++
593++instance Outputable TupleInfo where
594++ ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>
595++ text "stack" <+> ppr tupleNativeStackSize <+>
596++ text "regs" <+>
597++ char 'R' <> ppr tupleVanillaRegs <+>
598++ char 'L' <> ppr tupleLongRegs <+>
599++ char 'F' <> ppr tupleFloatRegs <+>
600++ char 'D' <> ppr tupleDoubleRegs <>
601++ char '>'
602++
603+ type ItblEnv = NameEnv (Name, ItblPtr)
604+ -- We need the Name in the range so we know which
605+ -- elements to filter out when unloading a module
606+diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
607+index 6599da07f4..d587f9c88e 100644
608+--- a/compiler/main/GhcMake.hs
609++++ b/compiler/main/GhcMake.hs
610+@@ -2078,7 +2078,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
611+ (defaultObjectTarget dflags)
612+ map0
613+ else if hscTarget dflags == HscInterpreted
614+- then enableCodeGenForUnboxedTuplesOrSums
615++ then enableCodeGenForUnboxedSums
616+ (defaultObjectTarget dflags)
617+ map0
618+ else return map0
619+@@ -2177,23 +2177,21 @@ enableCodeGenForTH =
620+ --
621+ -- This is used used in order to load code that uses unboxed tuples
622+ -- or sums into GHCi while still allowing some code to be interpreted.
623+-enableCodeGenForUnboxedTuplesOrSums :: HscTarget
624++enableCodeGenForUnboxedSums :: HscTarget
625+ -> NodeMap [Either ErrorMessages ModSummary]
626+ -> IO (NodeMap [Either ErrorMessages ModSummary])
627+-enableCodeGenForUnboxedTuplesOrSums =
628++enableCodeGenForUnboxedSums =
629+ enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
630+ where
631+ condition ms =
632+- unboxed_tuples_or_sums (ms_hspp_opts ms) &&
633++ xopt LangExt.UnboxedSums (ms_hspp_opts ms) &&
634+ not (gopt Opt_ByteCode (ms_hspp_opts ms)) &&
635+ not (isBootSummary ms)
636+- unboxed_tuples_or_sums d =
637+- xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d
638+ should_modify (ModSummary { ms_hspp_opts = dflags }) =
639+ hscTarget dflags == HscInterpreted
640+
641+ -- | Helper used to implement 'enableCodeGenForTH' and
642+--- 'enableCodeGenForUnboxedTuples'. In particular, this enables
643++-- 'enableCodeGenForUnboxedSums'. In particular, this enables
644+ -- unoptimized code generation for all modules that meet some
645+ -- condition (first parameter), or are dependencies of those
646+ -- modules. The second parameter is a condition to check before
647+diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
648+index e5d55f694f..88748ea184 100644
649+--- a/includes/rts/Bytecodes.h
650++++ b/includes/rts/Bytecodes.h
651+@@ -91,6 +91,9 @@
652+ #define bci_BRK_FUN 66
653+ #define bci_TESTLT_W 67
654+ #define bci_TESTEQ_W 68
655++
656++#define bci_RETURN_T 69
657++#define bci_PUSH_ALTS_T 70
658+ /* If you need to go past 255 then you will run into the flags */
659+
660+ /* If you need to go below 0x0100 then you will run into the instructions */
661+diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
662+index 5b2364407f..f98401cc98 100644
663+--- a/includes/stg/MiscClosures.h
664++++ b/includes/stg/MiscClosures.h
665+@@ -87,6 +87,41 @@ RTS_RET(stg_ctoi_D1);
666+ RTS_RET(stg_ctoi_L1);
667+ RTS_RET(stg_ctoi_V);
668+
669++RTS_FUN_DECL(stg_ctoi_t);
670++RTS_RET(stg_ctoi_t0);
671++RTS_RET(stg_ctoi_t1);
672++RTS_RET(stg_ctoi_t2);
673++RTS_RET(stg_ctoi_t3);
674++RTS_RET(stg_ctoi_t4);
675++RTS_RET(stg_ctoi_t5);
676++RTS_RET(stg_ctoi_t6);
677++RTS_RET(stg_ctoi_t7);
678++RTS_RET(stg_ctoi_t8);
679++RTS_RET(stg_ctoi_t9);
680++RTS_RET(stg_ctoi_t10);
681++RTS_RET(stg_ctoi_t11);
682++RTS_RET(stg_ctoi_t12);
683++RTS_RET(stg_ctoi_t13);
684++RTS_RET(stg_ctoi_t14);
685++RTS_RET(stg_ctoi_t15);
686++RTS_RET(stg_ctoi_t16);
687++RTS_RET(stg_ctoi_t17);
688++RTS_RET(stg_ctoi_t18);
689++RTS_RET(stg_ctoi_t19);
690++RTS_RET(stg_ctoi_t20);
691++RTS_RET(stg_ctoi_t21);
692++RTS_RET(stg_ctoi_t22);
693++RTS_RET(stg_ctoi_t23);
694++RTS_RET(stg_ctoi_t24);
695++RTS_RET(stg_ctoi_t25);
696++RTS_RET(stg_ctoi_t26);
697++RTS_RET(stg_ctoi_t27);
698++RTS_RET(stg_ctoi_t28);
699++RTS_RET(stg_ctoi_t29);
700++RTS_RET(stg_ctoi_t30);
701++RTS_RET(stg_ctoi_t31);
702++RTS_RET(stg_ctoi_t32);
703++
704+ RTS_RET(stg_apply_interp);
705+
706+ RTS_ENTRY(stg_IND);
707+@@ -293,6 +328,7 @@ RTS_RET(stg_ret_n);
708+ RTS_RET(stg_ret_f);
709+ RTS_RET(stg_ret_d);
710+ RTS_RET(stg_ret_l);
711++RTS_RET(stg_ret_t);
712+
713+ RTS_FUN_DECL(stg_gc_prim);
714+ RTS_FUN_DECL(stg_gc_prim_p);
715+diff --git a/rts/Disassembler.c b/rts/Disassembler.c
716+index 01d6c3b1d9..bae23c1f17 100644
717+--- a/rts/Disassembler.c
718++++ b/rts/Disassembler.c
719+@@ -148,6 +148,13 @@ disInstr ( StgBCO *bco, int pc )
720+ debugBelch("PUSH_ALTS_V " ); printPtr( ptrs[instrs[pc]] );
721+ debugBelch("\n");
722+ pc += 1; break;
723++ case bci_PUSH_ALTS_T:
724++ debugBelch("PUSH_ALTS_T ");
725++ printPtr( ptrs[instrs[pc]] );
726++ debugBelch(" 0x%" FMT_HexWord " ", literals[instrs[pc+1]] );
727++ printPtr( ptrs[instrs[pc+2]] );
728++ debugBelch("\n");
729++ pc += 3; break;
730+ case bci_PUSH_PAD8:
731+ debugBelch("PUSH_PAD8\n");
732+ pc += 1; break;
733+@@ -313,6 +320,9 @@ disInstr ( StgBCO *bco, int pc )
734+ case bci_RETURN_V:
735+ debugBelch("RETURN_V\n" );
736+ break;
737++ case bci_RETURN_T:
738++ debugBelch("RETURN_T\n ");
739++ break;
740+
741+ default:
742+ barf("disInstr: unknown opcode %u", (unsigned int) instr);
743+diff --git a/rts/Interpreter.c b/rts/Interpreter.c
744+index 463ddae18b..f33fb9c73e 100644
745+--- a/rts/Interpreter.c
746++++ b/rts/Interpreter.c
747+@@ -681,12 +681,13 @@ do_return_unboxed:
748+ || SpW(0) == (W_)&stg_ret_f_info
749+ || SpW(0) == (W_)&stg_ret_d_info
750+ || SpW(0) == (W_)&stg_ret_l_info
751++ || SpW(0) == (W_)&stg_ret_t_info
752+ );
753+
754+ IF_DEBUG(interpreter,
755+ debugBelch(
756+ "\n---------------------------------------------------------------\n");
757+- debugBelch("Returning: "); printObj(obj);
758++ debugBelch("Returning unboxed\n");
759+ debugBelch("Sp = %p\n", Sp);
760+ #if defined(PROFILING)
761+ fprintCCS(stderr, cap->r.rCCCS);
762+@@ -697,7 +698,7 @@ do_return_unboxed:
763+ debugBelch("\n\n");
764+ );
765+
766+- // get the offset of the stg_ctoi_ret_XXX itbl
767++ // get the offset of the stg_ctoi_XXX itbl
768+ offset = stack_frame_sizeW((StgClosure *)Sp);
769+
770+ switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
771+@@ -1326,6 +1327,64 @@ run_BCO:
772+ goto nextInsn;
773+ }
774+
775++ case bci_PUSH_ALTS_T: {
776++ int o_bco = BCO_GET_LARGE_ARG;
777++ W_ tuple_info = (W_)BCO_LIT(BCO_GET_LARGE_ARG);
778++ int o_tuple_bco = BCO_GET_LARGE_ARG;
779++
780++ SpW(-1) = BCO_PTR(o_tuple_bco);
781++ SpW(-2) = tuple_info;
782++ SpW(-3) = BCO_PTR(o_bco);
783++ W_ ctoi_t_offset;
784++ int tuple_stack_words = tuple_info & 0x3fff;
785++ switch(tuple_stack_words) {
786++ case 0: ctoi_t_offset = (W_)&stg_ctoi_t0_info; break;
787++ case 1: ctoi_t_offset = (W_)&stg_ctoi_t1_info; break;
788++ case 2: ctoi_t_offset = (W_)&stg_ctoi_t2_info; break;
789++ case 3: ctoi_t_offset = (W_)&stg_ctoi_t3_info; break;
790++ case 4: ctoi_t_offset = (W_)&stg_ctoi_t4_info; break;
791++ case 5: ctoi_t_offset = (W_)&stg_ctoi_t5_info; break;
792++ case 6: ctoi_t_offset = (W_)&stg_ctoi_t6_info; break;
793++ case 7: ctoi_t_offset = (W_)&stg_ctoi_t7_info; break;
794++ case 8: ctoi_t_offset = (W_)&stg_ctoi_t8_info; break;
795++ case 9: ctoi_t_offset = (W_)&stg_ctoi_t9_info; break;
796++ case 10: ctoi_t_offset = (W_)&stg_ctoi_t10_info; break;
797++ case 11: ctoi_t_offset = (W_)&stg_ctoi_t11_info; break;
798++ case 12: ctoi_t_offset = (W_)&stg_ctoi_t12_info; break;
799++ case 13: ctoi_t_offset = (W_)&stg_ctoi_t13_info; break;
800++ case 14: ctoi_t_offset = (W_)&stg_ctoi_t14_info; break;
801++ case 15: ctoi_t_offset = (W_)&stg_ctoi_t15_info; break;
802++ case 16: ctoi_t_offset = (W_)&stg_ctoi_t16_info; break;
803++ case 17: ctoi_t_offset = (W_)&stg_ctoi_t17_info; break;
804++ case 18: ctoi_t_offset = (W_)&stg_ctoi_t18_info; break;
805++ case 19: ctoi_t_offset = (W_)&stg_ctoi_t19_info; break;
806++ case 20: ctoi_t_offset = (W_)&stg_ctoi_t20_info; break;
807++ case 21: ctoi_t_offset = (W_)&stg_ctoi_t21_info; break;
808++ case 22: ctoi_t_offset = (W_)&stg_ctoi_t22_info; break;
809++ case 23: ctoi_t_offset = (W_)&stg_ctoi_t23_info; break;
810++ case 24: ctoi_t_offset = (W_)&stg_ctoi_t24_info; break;
811++ case 25: ctoi_t_offset = (W_)&stg_ctoi_t25_info; break;
812++ case 26: ctoi_t_offset = (W_)&stg_ctoi_t26_info; break;
813++ case 27: ctoi_t_offset = (W_)&stg_ctoi_t27_info; break;
814++ case 28: ctoi_t_offset = (W_)&stg_ctoi_t28_info; break;
815++ case 29: ctoi_t_offset = (W_)&stg_ctoi_t29_info; break;
816++ case 30: ctoi_t_offset = (W_)&stg_ctoi_t30_info; break;
817++ case 31: ctoi_t_offset = (W_)&stg_ctoi_t31_info; break;
818++ case 32: ctoi_t_offset = (W_)&stg_ctoi_t32_info; break;
819++
820++ default: barf("unsupported tuple size %d", tuple_stack_words);
821++ }
822++ SpW(-4) = ctoi_t_offset;
823++ Sp_subW(4);
824++ /* XXX this cannot work yet */
825++ /* #if defined(PROFILING)
826++ Sp_subW(2);
827++ SpW(1) = (W_)cap->r.rCCCS;
828++ SpW(0) = (W_)&stg_restore_cccs_info;
829++ #endif */
830++ goto nextInsn;
831++ }
832++
833+ case bci_PUSH_APPLY_N:
834+ Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
835+ goto nextInsn;
836+@@ -1705,6 +1764,12 @@ run_BCO:
837+ Sp_subW(1);
838+ SpW(0) = (W_)&stg_ret_v_info;
839+ goto do_return_unboxed;
840++ case bci_RETURN_T: {
841++ /* tuple_info and tuple_bco must already be on the stack */
842++ Sp_subW(1);
843++ SpW(0) = (W_)&stg_ret_t_info;
844++ goto do_return_unboxed;
845++ }
846+
847+ case bci_SWIZZLE: {
848+ int stkoff = BCO_NEXT;
849+diff --git a/rts/Printer.c b/rts/Printer.c
850+index 15404e1205..ab2119cf78 100644
851+--- a/rts/Printer.c
852++++ b/rts/Printer.c
853+@@ -528,17 +528,7 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
854+
855+ case RET_SMALL: {
856+ StgWord c = *sp;
857+- if (c == (StgWord)&stg_ctoi_R1p_info) {
858+- debugBelch("tstg_ctoi_ret_R1p_info\n" );
859+- } else if (c == (StgWord)&stg_ctoi_R1n_info) {
860+- debugBelch("stg_ctoi_ret_R1n_info\n" );
861+- } else if (c == (StgWord)&stg_ctoi_F1_info) {
862+- debugBelch("stg_ctoi_ret_F1_info\n" );
863+- } else if (c == (StgWord)&stg_ctoi_D1_info) {
864+- debugBelch("stg_ctoi_ret_D1_info\n" );
865+- } else if (c == (StgWord)&stg_ctoi_V_info) {
866+- debugBelch("stg_ctoi_ret_V_info\n" );
867+- } else if (c == (StgWord)&stg_ap_v_info) {
868++ if (c == (StgWord)&stg_ap_v_info) {
869+ debugBelch("stg_ap_v_info\n" );
870+ } else if (c == (StgWord)&stg_ap_f_info) {
871+ debugBelch("stg_ap_f_info\n" );
872+@@ -594,11 +584,51 @@ printStackChunk( StgPtr sp, StgPtr spBottom )
873+ }
874+
875+ case RET_BCO: {
876+- StgBCO *bco;
877+-
878+- bco = ((StgBCO *)sp[1]);
879++ StgWord c = *sp;
880++ StgBCO *bco = ((StgBCO *)sp[1]);
881+
882+- debugBelch("RET_BCO (%p)\n", sp);
883++ if (c == (StgWord)&stg_ctoi_R1p_info) {
884++ debugBelch("stg_ctoi_R1p_info" );
885++ } else if (c == (StgWord)&stg_ctoi_R1unpt_info) {
886++ debugBelch("stg_ctoi_R1unpt_info" );
887++ } else if (c == (StgWord)&stg_ctoi_R1n_info) {
888++ debugBelch("stg_ctoi_R1n_info" );
889++ } else if (c == (StgWord)&stg_ctoi_F1_info) {
890++ debugBelch("stg_ctoi_F1_info" );
891++ } else if (c == (StgWord)&stg_ctoi_D1_info) {
892++ debugBelch("stg_ctoi_D1_info" );
893++ } else if (c == (StgWord)&stg_ctoi_V_info) {
894++ debugBelch("stg_ctoi_V_info" );
895++ } else if (c == (StgWord)&stg_BCO_info) {
896++ debugBelch("stg_BCO_info" );
897++ } else if (c == (StgWord)&stg_apply_interp_info) {
898++ debugBelch("stg_apply_interp_info" );
899++ } else if (c == (StgWord)&stg_ret_t_info) {
900++ debugBelch("stg_ret_t_info" );
901++ } else if (c == (StgWord)&stg_ctoi_t0_info) {
902++ debugBelch("stg_ctoi_t0_info" );
903++ } else if (c == (StgWord)&stg_ctoi_t1_info) {
904++ debugBelch("stg_ctoi_t1_info" );
905++ } else if (c == (StgWord)&stg_ctoi_t2_info) {
906++ debugBelch("stg_ctoi_t2_info" );
907++ } else if (c == (StgWord)&stg_ctoi_t3_info) {
908++ debugBelch("stg_ctoi_t3_info" );
909++ } else if (c == (StgWord)&stg_ctoi_t4_info) {
910++ debugBelch("stg_ctoi_t4_info" );
911++ } else if (c == (StgWord)&stg_ctoi_t5_info) {
912++ debugBelch("stg_ctoi_t5_info" );
913++ } else if (c == (StgWord)&stg_ctoi_t6_info) {
914++ debugBelch("stg_ctoi_t6_info" );
915++ } else if (c == (StgWord)&stg_ctoi_t7_info) {
916++ debugBelch("stg_ctoi_t7_info" );
917++ } else if (c == (StgWord)&stg_ctoi_t8_info) {
918++ debugBelch("stg_ctoi_t8_info" );
919++ /* there are more stg_ctoi_tN_info frames,
920++ but we don't print them all */
921++ } else {
922++ debugBelch("RET_BCO");
923++ }
924++ debugBelch(" (%p)\n", sp);
925+ printLargeBitmap(spBottom, sp+2,
926+ BCO_BITMAP(bco), BCO_BITMAP_SIZE(bco));
927+ continue;
928+diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
929+index b2f90a892d..9ad6806c18 100644
930+--- a/rts/RtsSymbols.c
931++++ b/rts/RtsSymbols.c
932+@@ -551,6 +551,8 @@
933+ SymI_HasProto(stg_ret_f_info) \
934+ SymI_HasProto(stg_ret_d_info) \
935+ SymI_HasProto(stg_ret_l_info) \
936++ SymI_HasProto(stg_ret_t_info) \
937++ SymI_HasProto(stg_ctoi_t) \
938+ SymI_HasProto(stg_gc_prim_p) \
939+ SymI_HasProto(stg_gc_prim_pp) \
940+ SymI_HasProto(stg_gc_prim_n) \
941+diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
942+index 44d7d302e5..015a6b50f6 100644
943+--- a/rts/StgMiscClosures.cmm
944++++ b/rts/StgMiscClosures.cmm
945+@@ -195,6 +195,236 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
946+ jump stg_yield_to_interpreter [];
947+ }
948+
949++/* In the calling convention for compiled code, a tuple is returned
950++ in registers, with everything that doesn't fit spilled onto the STG
951++ stack.
952++
953++ At the time the continuation is called, Sp points to the highest word
954++ used on the stack:
955++
956++ ...
957++ stg_ctoi_t (next stack frame, continuation)
958++ spilled_1
959++ spilled_2
960++ spilled_3 <- Sp
961++
962++ This makes it difficult to write a procedure that can handle tuples of
963++ any size.
964++
965++ To get around this, we use a Cmm procedure that adjusts the stack pointer
966++ to skip over the tuple:
967++
968++ ...
969++ stg_ctoi_t3 (advances Sp by 3 words, then calls stg_ctoi_t)
970++ spilled_1
971++ spilled_2
972++ spilled_3 <- Sp
973++
974++ When stg_ctoi_t is called, the stack looks like:
975++
976++ ...
977++ tuple_BCO
978++ tuple_info
979++ cont_BCO (continuation in bytecode)
980++ stg_ctoi_t3 <- Sp
981++ spilled_1
982++ spilled_2
983++ spilled_3
984++
985++ stg_ctoi_t then reads the tuple_info word to determine the registers
986++ to save onto the stack and construct a call to tuple_BCO. Afterwards the
987++ stack looks as follows:
988++
989++ ...
990++ tuple_BCO
991++ tuple_info
992++ cont_BCO
993++ stg_ctoi_t3
994++ spilled_1
995++ spilled_2
996++ spilled_3
997++ saved_R2
998++ saved_R1
999++ saved_D3
1000++ ...
1001++ tuple_BCO
1002++ stg_apply_interp <- Sp
1003++
1004++
1005++ tuple_BCO contains the bytecode instructions to return the tuple to
1006++ cont_BCO. The bitmap in tuple_BCO describes the contents of
1007++ the tuple to the storage manager.
1008++
1009++ At this point we can safely jump to the interpreter.
1010++
1011++ */
1012++
1013++#define MK_STG_CTOI_T(N) INFO_TABLE_RET( \
1014++ stg_ctoi_t ## N, RET_BCO ) \
1015++ { Sp_adj(N); jump stg_ctoi_t [*]; }
1016++
1017++MK_STG_CTOI_T(0)
1018++MK_STG_CTOI_T(1)
1019++MK_STG_CTOI_T(2)
1020++MK_STG_CTOI_T(3)
1021++MK_STG_CTOI_T(4)
1022++MK_STG_CTOI_T(5)
1023++MK_STG_CTOI_T(6)
1024++MK_STG_CTOI_T(7)
1025++MK_STG_CTOI_T(8)
1026++MK_STG_CTOI_T(9)
1027++MK_STG_CTOI_T(10)
1028++MK_STG_CTOI_T(11)
1029++MK_STG_CTOI_T(12)
1030++MK_STG_CTOI_T(13)
1031++MK_STG_CTOI_T(14)
1032++MK_STG_CTOI_T(15)
1033++MK_STG_CTOI_T(16)
1034++MK_STG_CTOI_T(17)
1035++MK_STG_CTOI_T(18)
1036++MK_STG_CTOI_T(19)
1037++MK_STG_CTOI_T(20)
1038++MK_STG_CTOI_T(21)
1039++MK_STG_CTOI_T(22)
1040++MK_STG_CTOI_T(23)
1041++MK_STG_CTOI_T(24)
1042++MK_STG_CTOI_T(25)
1043++MK_STG_CTOI_T(26)
1044++MK_STG_CTOI_T(27)
1045++MK_STG_CTOI_T(28)
1046++MK_STG_CTOI_T(29)
1047++MK_STG_CTOI_T(30)
1048++MK_STG_CTOI_T(31)
1049++MK_STG_CTOI_T(32)
1050++
1051++/*
1052++ the tuple_info word describes the register and stack usage of the tuple:
1053++
1054++ [ rrrr ffff ffdd dddd llss ssss ssss ssss ]
1055++
1056++ - r: number of vanilla registers R1..Rn
1057++ - f: bitmap of float registers F1..F6
1058++ - d: bitmap of double registers D1..D6
1059++ - l: bitmap of long registers L1..Ln
1060++ - s: size of tuple in words on stack
1061++
1062++ the order in which the registers are pushed on the stack is determined by
1063++ the Ord instance of GHC.Cmm.Expr.GlobalReg
1064++
1065++ */
1066++
1067++stg_ctoi_t
1068++ /* explicit stack */
1069++{
1070++
1071++ W_ tuple_info, tuple_stack, tuple_regs_R,
1072++ tuple_regs_F, tuple_regs_D, tuple_regs_L;
1073++ P_ tuple_BCO;
1074++
1075++ tuple_info = Sp(2); /* tuple information word */
1076++ tuple_BCO = Sp(3); /* bytecode object that returns the tuple in
1077++ the interpreter */
1078++
1079++ tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */
1080++ tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */
1081++ tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */
1082++ tuple_regs_D = (tuple_info >> 16) & 0x3f; /* 6 bits bitmap */
1083++ tuple_regs_L = (tuple_info >> 14) & 0x3; /* 2 bits bitmap */
1084++
1085++ Sp = Sp - WDS(tuple_stack);
1086++
1087++ /* save long registers */
1088++ /* fixme L2 ? */
1089++ if((tuple_regs_L & 1) != 0) { Sp = Sp - 8; L_[Sp] = L1; }
1090++
1091++ /* save double registers */
1092++ if((tuple_regs_D & 32) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D6; }
1093++ if((tuple_regs_D & 16) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D5; }
1094++ if((tuple_regs_D & 8) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D4; }
1095++ if((tuple_regs_D & 4) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D3; }
1096++ if((tuple_regs_D & 2) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D2; }
1097++ if((tuple_regs_D & 1) != 0) { Sp = Sp - SIZEOF_DOUBLE; D_[Sp] = D1; }
1098++
1099++ /* save float registers */
1100++ if((tuple_regs_F & 32) != 0) { Sp_adj(-1); F_[Sp] = F6; }
1101++ if((tuple_regs_F & 16) != 0) { Sp_adj(-1); F_[Sp] = F5; }
1102++ if((tuple_regs_F & 8) != 0) { Sp_adj(-1); F_[Sp] = F4; }
1103++ if((tuple_regs_F & 4) != 0) { Sp_adj(-1); F_[Sp] = F3; }
1104++ if((tuple_regs_F & 2) != 0) { Sp_adj(-1); F_[Sp] = F2; }
1105++ if((tuple_regs_F & 1) != 0) { Sp_adj(-1); F_[Sp] = F1; }
1106++
1107++ /* save vanilla registers */
1108++ if(tuple_regs_R >= 6) { Sp_adj(-1); Sp(0) = R6; }
1109++ if(tuple_regs_R >= 5) { Sp_adj(-1); Sp(0) = R5; }
1110++ if(tuple_regs_R >= 4) { Sp_adj(-1); Sp(0) = R4; }
1111++ if(tuple_regs_R >= 3) { Sp_adj(-1); Sp(0) = R3; }
1112++ if(tuple_regs_R >= 2) { Sp_adj(-1); Sp(0) = R2; }
1113++ if(tuple_regs_R >= 1) { Sp_adj(-1); Sp(0) = R1; }
1114++
1115++ /* jump to the BCO that will finish the return of the tuple */
1116++ Sp_adj(-3);
1117++ Sp(2) = tuple_info;
1118++ Sp(1) = tuple_BCO;
1119++ Sp(0) = stg_ret_t_info;
1120++
1121++ jump stg_yield_to_interpreter [];
1122++}
1123++
1124++INFO_TABLE_RET( stg_ret_t, RET_BCO )
1125++{
1126++ W_ tuple_info, tuple_stack, tuple_regs_R, tuple_regs_F,
1127++ tuple_regs_D, tuple_regs_L;
1128++
1129++ tuple_info = Sp(2);
1130++ Sp_adj(3);
1131++
1132++ tuple_stack = tuple_info & 0x3fff; /* number of words spilled on stack */
1133++ tuple_regs_R = (tuple_info >> 28) & 0xf; /* number of R1..Rn */
1134++ tuple_regs_F = (tuple_info >> 22) & 0x3f; /* 6 bits bitmap */
1135++ tuple_regs_D = (tuple_info >> 16) & 0x3f; /* 6 bits bitmap */
1136++ tuple_regs_L = (tuple_info >> 14) & 0x3; /* 2 bits bitmap */
1137++
1138++ /* ccall debugBelch("stg_ret_t: stack%d R%d F%d D%d L%d\n",
1139++ tuple_stack,
1140++ tuple_regs_R,
1141++ tuple_regs_F,
1142++ tuple_regs_D,
1143++ tuple_regs_L); */
1144++
1145++ /* restore everything in the reverse order of stg_ctoi_t */
1146++
1147++ /* restore vanilla registers */
1148++ if(tuple_regs_R >= 1) { R1 = Sp(0); Sp_adj(1); }
1149++ if(tuple_regs_R >= 2) { R2 = Sp(0); Sp_adj(1); }
1150++ if(tuple_regs_R >= 3) { R3 = Sp(0); Sp_adj(1); }
1151++ if(tuple_regs_R >= 4) { R4 = Sp(0); Sp_adj(1); }
1152++ if(tuple_regs_R >= 5) { R5 = Sp(0); Sp_adj(1); }
1153++ if(tuple_regs_R >= 6) { R6 = Sp(0); Sp_adj(1); }
1154++
1155++ /* restore float registers */
1156++ if((tuple_regs_F & 1) != 0) { F1 = F_[Sp]; Sp_adj(1); }
1157++ if((tuple_regs_F & 2) != 0) { F2 = F_[Sp]; Sp_adj(1); }
1158++ if((tuple_regs_F & 4) != 0) { F3 = F_[Sp]; Sp_adj(1); }
1159++ if((tuple_regs_F & 8) != 0) { F4 = F_[Sp]; Sp_adj(1); }
1160++ if((tuple_regs_F & 16) != 0) { F5 = F_[Sp]; Sp_adj(1); }
1161++ if((tuple_regs_F & 32) != 0) { F6 = F_[Sp]; Sp_adj(1); }
1162++
1163++ /* restore double registers */
1164++ if((tuple_regs_D & 1) != 0) { D1 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1165++ if((tuple_regs_D & 2) != 0) { D2 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1166++ if((tuple_regs_D & 4) != 0) { D3 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1167++ if((tuple_regs_D & 8) != 0) { D4 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1168++ if((tuple_regs_D & 16) != 0) { D5 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1169++ if((tuple_regs_D & 32) != 0) { D6 = D_[Sp]; Sp = Sp + SIZEOF_DOUBLE; }
1170++
1171++ /* restore long registers */
1172++ if((tuple_regs_L & 1) != 0) { L1 = L_[Sp]; Sp = Sp + 8; }
1173++
1174++ /* Sp points to the topmost argument now */
1175++ jump Sp(tuple_stack) [*]; // NB. all registers live!
1176++}
1177++
1178++
1179+ /*
1180+ * Dummy info table pushed on the top of the stack when the interpreter
1181+ * should apply the BCO on the stack to its arguments, also on the
1182+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
1183+new file mode 100644
1184+index 0000000000..80992405b5
1185+--- /dev/null
1186++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
1187+@@ -0,0 +1,219 @@
1188++type T1 a = a -> (# a #)
1189++tuple1 :: T1 a
1190++tuple1 x = (# x #)
1191++
1192++tuple1a :: a -> T1 a -> a
1193++tuple1a x f = case f x of (# y #) -> y
1194++
1195++-- can still be returned in registers, pointers
1196++type T2p a = a -> a -> a -> a -> (# a, a, a, a #)
1197++
1198++tuple2p :: T2p a
1199++tuple2p x1 x2 x3 x4 = (# x1, x2, x3, x4 #)
1200++
1201++tuple2p_a :: T2p a -> a -> a -> a -> a -> (a, a, a, a)
1202++tuple2p_a f x1 x2 x3 x4 =
1203++ case f x1 x2 x3 x4 of (# y1, y2, y3, y4 #) -> (y1, y2, y3, y4)
1204++
1205++-- can still be returned in registers, non-pointers
1206++type T2n = Int -> Int -> Int -> Int -> (# Int#, Int#, Int#, Int# #)
1207++
1208++tuple2n :: T2n
1209++tuple2n (I# x1) (I# x2) (I# x3) (I# x4) = (# x1, x2, x3, x4 #)
1210++
1211++tuple2n_a :: T2n -> Int -> Int -> Int -> Int -> (Int, Int, Int, Int)
1212++tuple2n_a f x1 x2 x3 x4 =
1213++ case f x1 x2 x3 x4 of
1214++ (# y1, y2, y3, y4 #) -> (I# y1, I# y2, I# y3, I# y4)
1215++
1216++
1217++-- too big to fit in registers
1218++type T3 a = a -> a -> a -> a
1219++ -> a -> a -> a -> a
1220++ -> a -> a -> a -> a
1221++ -> (# a, a, a, a
1222++ , a, a, a, a
1223++ , a, a, a, a #)
1224++tuple3 :: T3 a
1225++tuple3 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
1226++ (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #)
1227++
1228++tuple3_a :: T3 a
1229++ -> a -> a -> a -> a
1230++ -> a -> a -> a -> a
1231++ -> a -> a -> a -> a
1232++ -> ( a, a, a, a
1233++ , a, a, a, a
1234++ , a, a, a, a
1235++ )
1236++tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
1237++ case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 of
1238++ (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12 #) ->
1239++ (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12)
1240++
1241++type T4a = Float -> Double -> Float -> Double
1242++ -> (# Float#, Double#, Float#, Double# #)
1243++
1244++tuple4a :: T4a
1245++tuple4a (F# f1) (D# d1) (F# f2) (D# d2) = (# f1, d1, f2, d2 #)
1246++
1247++tuple4a_a :: T4a
1248++ -> Float -> Double -> Float -> Double
1249++ -> (Float, Double, Float, Double)
1250++tuple4a_a h f1 d1 f2 d2 =
1251++ case h f1 d1 f2 d2 of (# g1, e1, g2, e2 #) -> (F# g1, D# e1, F# g2, D# e2 )
1252++
1253++
1254++-- this should fill the floating point registers
1255++type T4b = Float -> Double -> Float -> Double
1256++ -> Float -> Double -> Float -> Double
1257++ -> Float -> Double -> Float -> Double
1258++ -> Float -> Double -> Float -> Double
1259++ -> Float -> Double -> Float -> Double
1260++ -> (# Float#, Double#, Float#, Double#
1261++ , Float#, Double#, Float#, Double#
1262++ , Float#, Double#, Float#, Double#
1263++ , Float#, Double#, Float#, Double#
1264++ , Float#, Double#, Float#, Double# #)
1265++tuple4b :: T4b
1266++tuple4b (F# f1) (D# d1) (F# f2) (D# d2)
1267++ (F# f3) (D# d3) (F# f4) (D# d4)
1268++ (F# f5) (D# d5) (F# f6) (D# d6)
1269++ (F# f7) (D# d7) (F# f8) (D# d8)
1270++ (F# f9) (D# d9) (F# f10) (D# d10) =
1271++ (# f1, d1, f2, d2
1272++ , f3, d3, f4, d4
1273++ , f5, d5, f6, d6
1274++ , f7, d7, f8, d8
1275++ , f9, d9, f10, d10
1276++ #)
1277++
1278++tuple4b_a :: T4b
1279++ -> Float -> Double -> Float -> Double
1280++ -> Float -> Double -> Float -> Double
1281++ -> Float -> Double -> Float -> Double
1282++ -> Float -> Double -> Float -> Double
1283++ -> Float -> Double -> Float -> Double
1284++ -> ( (Float, Double, Float, Double)
1285++ , (Float, Double, Float, Double)
1286++ , (Float, Double, Float, Double)
1287++ , (Float, Double, Float, Double)
1288++ , (Float, Double, Float, Double)
1289++ )
1290++tuple4b_a h f1 d1 f2 d2
1291++ f3 d3 f4 d4
1292++ f5 d5 f6 d6
1293++ f7 d7 f8 d8
1294++ f9 d9 f10 d10 =
1295++ case h f1 d1 f2 d2
1296++ f3 d3 f4 d4
1297++ f5 d5 f6 d6
1298++ f7 d7 f8 d8
1299++ f9 d9 f10 d10 of
1300++ (# g1, e1, g2, e2
1301++ , g3, e3, g4, e4
1302++ , g5, e5, g6, e6
1303++ , g7, e7, g8, e8
1304++ , g9, e9, g10, e10 #) ->
1305++ ( (F# g1, D# e1, F# g2, D# e2)
1306++ , (F# g3, D# e3, F# g4, D# e4)
1307++ , (F# g5, D# e5, F# g6, D# e6)
1308++ , (F# g7, D# e7, F# g8, D# e8)
1309++ , (F# g9, D# e9, F# g10, D# e10))
1310++
1311++type T4c = Float -> Double -> Word64 -> Integer
1312++ -> Float -> Double -> Word64 -> Integer
1313++ -> Float -> Double -> Word64 -> Integer
1314++ -> Float -> Double -> Word64 -> Integer
1315++ -> (# Float#, Double#, WW#, Integer
1316++ , Float#, Double#, WW#, Integer
1317++ , Float#, Double#, WW#, Integer
1318++ , Float#, Double#, WW#, Integer
1319++ #)
1320++tuple4c :: T4c
1321++tuple4c (F# f1) (D# d1) (W64# w1) i1
1322++ (F# f2) (D# d2) (W64# w2) i2
1323++ (F# f3) (D# d3) (W64# w3) i3
1324++ (F# f4) (D# d4) (W64# w4) i4 =
1325++ (# f1, d1, w1, i1
1326++ , f2, d2, w2, i2
1327++ , f3, d3, w3, i3
1328++ , f4, d4, w4, i4
1329++ #)
1330++
1331++tuple4c_a :: T4c
1332++ -> Float -> Double -> Word64 -> Integer
1333++ -> Float -> Double -> Word64 -> Integer
1334++ -> Float -> Double -> Word64 -> Integer
1335++ -> Float -> Double -> Word64 -> Integer
1336++ -> ( ( Float, Double, Word64, Integer)
1337++ , ( Float, Double, Word64, Integer)
1338++ , ( Float, Double, Word64, Integer)
1339++ , ( Float, Double, Word64, Integer)
1340++ )
1341++tuple4c_a h f1 d1 w1 i1
1342++ f2 d2 w2 i2
1343++ f3 d3 w3 i3
1344++ f4 d4 w4 i4 =
1345++ case h f1 d1 w1 i1
1346++ f2 d2 w2 i2
1347++ f3 d3 w3 i3
1348++ f4 d4 w4 i4 of
1349++ (# f1', d1', w1', i1'
1350++ , f2', d2', w2', i2'
1351++ , f3', d3', w3', i3'
1352++ , f4', d4', w4', i4' #) ->
1353++ ( (F# f1', D# d1', W64# w1', i1')
1354++ , (F# f2', D# d2', W64# w2', i2')
1355++ , (F# f3', D# d3', W64# w3', i3')
1356++ , (F# f4', D# d4', W64# w4', i4')
1357++ )
1358++
1359++type T5 = Int -> Word64 -> Int -> Word64
1360++ -> Int -> Word64 -> Int -> Word64
1361++ -> Int -> Word64 -> Int -> Word64
1362++ -> Int -> Word64 -> Int -> Word64
1363++ -> (# Int, WW#, Int, WW#
1364++ , Int, WW#, Int, WW#
1365++ , Int, WW#, Int, WW#
1366++ , Int, WW#, Int, WW#
1367++ #)
1368++
1369++tuple5 :: T5
1370++tuple5 i1 (W64# w1) i2 (W64# w2)
1371++ i3 (W64# w3) i4 (W64# w4)
1372++ i5 (W64# w5) i6 (W64# w6)
1373++ i7 (W64# w7) i8 (W64# w8) =
1374++ (# i1, w1, i2, w2
1375++ , i3, w3, i4, w4
1376++ , i5, w5, i6, w6
1377++ , i7, w7, i8, w8 #)
1378++
1379++tuple5_a :: T5
1380++ -> Int -> Word64 -> Int -> Word64
1381++ -> Int -> Word64 -> Int -> Word64
1382++ -> Int -> Word64 -> Int -> Word64
1383++ -> Int -> Word64 -> Int -> Word64
1384++ -> ( (Int, Word64, Int, Word64)
1385++ , (Int, Word64, Int, Word64)
1386++ , (Int, Word64, Int, Word64)
1387++ , (Int, Word64, Int, Word64)
1388++ )
1389++tuple5_a f i1 w1 i2 w2
1390++ i3 w3 i4 w4
1391++ i5 w5 i6 w6
1392++ i7 w7 i8 w8 =
1393++ case f i1 w1 i2 w2
1394++ i3 w3 i4 w4
1395++ i5 w5 i6 w6
1396++ i7 w7 i8 w8 of
1397++ (# j1, x1, j2, x2
1398++ , j3, x3, j4, x4
1399++ , j5, x5, j6, x6
1400++ , j7, x7, j8, x8
1401++ #) ->
1402++ ( (j1, W64# x1, j2, W64# x2)
1403++ , (j3, W64# x3, j4, W64# x4)
1404++ , (j5, W64# x5, j6, W64# x6)
1405++ , (j7, W64# x7, j8, W64# x8)
1406++ )
1407+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
1408+new file mode 100644
1409+index 0000000000..e9272583f0
1410+--- /dev/null
1411++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
1412+@@ -0,0 +1,17 @@
1413++{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
1414++{-# OPTIONS_GHC -fobject-code #-}
1415++
1416++#include "MachDeps.h"
1417++
1418++#if WORD_SIZE_IN_BITS < 64
1419++#define WW Word64
1420++#else
1421++#define WW Word
1422++#endif
1423++
1424++module Obj where
1425++
1426++import GHC.Exts
1427++import GHC.Word
1428++
1429++#include "Common.hs-incl"
1430+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
1431+new file mode 100644
1432+index 0000000000..f6cec4206f
1433+--- /dev/null
1434++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
1435+@@ -0,0 +1,83 @@
1436++{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}
1437++{-# OPTIONS_GHC -fbyte-code #-}
1438++
1439++#include "MachDeps.h"
1440++
1441++#if WORD_SIZE_IN_BITS < 64
1442++#define WW Word64
1443++#else
1444++#define WW Word
1445++#endif
1446++
1447++{-
1448++ Test unboxed tuples in the bytecode interpreter.
1449++
1450++ The bytecode interpreter uses the stack for everything, while
1451++ compiled code uses STG registers for arguments and return values.
1452++ -}
1453++
1454++module Main where
1455++
1456++import qualified Obj as O
1457++
1458++import GHC.Exts
1459++import GHC.Word
1460++
1461++main :: IO ()
1462++main = do
1463++
1464++ testX "tuple2p"
1465++ tuple2p_a O.tuple2p_a
1466++ tuple2p O.tuple2p
1467++ (\f -> f (1234::Integer) 1235 1236 1237)
1468++
1469++ testX "tuple2n"
1470++ tuple2n_a O.tuple2n_a
1471++ tuple2n O.tuple2n
1472++ (\f -> f 7654 7653 7652 7651)
1473++
1474++ testX "tuple3"
1475++ tuple3_a O.tuple3_a
1476++ tuple3 O.tuple3
1477++ (\f -> f (1000::Integer) 1001 1002 1003
1478++ 1004 1005 1006 1007
1479++ 1008 1009 1010 1011)
1480++
1481++ testX "tuple4a"
1482++ tuple4a_a O.tuple4a_a
1483++ tuple4a O.tuple4a
1484++ (\f -> f 2000 2001 2002 2003)
1485++
1486++ testX "tuple4b"
1487++ tuple4b_a O.tuple4b_a
1488++ tuple4b O.tuple4b
1489++ (\f -> f 3000 3001 3002 3003
1490++ 3004 3005 3006 3007
1491++ 3008 3009 3010 3011
1492++ 3012 3013 3014 3015
1493++ 3016 3017 3018 3019)
1494++
1495++ testX "tuple4c"
1496++ tuple4c_a O.tuple4c_a
1497++ tuple4c O.tuple4c
1498++ (\f -> f 3000 3001 3002 3003
1499++ 3004 3005 3006 3007
1500++ 3008 3009 3010 3011
1501++ 3012 3013 3014 3015)
1502++
1503++ testX "tuple5"
1504++ tuple5_a O.tuple5_a
1505++ tuple5 O.tuple5
1506++ (\f -> f 4000 4001 4002 4003
1507++ 4004 4005 4006 4007
1508++ 4008 4009 4010 4011
1509++ 4012 4013 4014 4015)
1510++
1511++
1512++testX :: (Eq a, Show a)
1513++ => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
1514++testX msg a1 a2 b1 b2 ap =
1515++ let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
1516++ in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
1517++
1518++#include "Common.hs-incl"
1519+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
1520+new file mode 100644
1521+index 0000000000..30acb50b07
1522+--- /dev/null
1523++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
1524+@@ -0,0 +1,7 @@
1525++tuple2p True (1234,1235,1236,1237)
1526++tuple2n True (7654,7653,7652,7651)
1527++tuple3 True (1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011)
1528++tuple4a True (2000.0,2001.0,2002.0,2003.0)
1529++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))
1530++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))
1531++tuple5 True ((4000,4001,4002,4003),(4004,4005,4006,4007),(4008,4009,4010,4011),(4012,4013,4014,4015))
1532+diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
1533+new file mode 100644
1534+index 0000000000..9439257683
1535+--- /dev/null
1536++++ b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
1537+@@ -0,0 +1,2 @@
1538++test('UnboxedTuples', [extra_files(['Obj.hs', 'Common.hs-incl']),
1539++ only_ways(['ghci'])], compile_and_run, [''])