@@ -0,0 +1,1127 @@
1+diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
2+index 743631527e..b01d6640c3 100644
3+--- a/compiler/cmm/SMRep.hs
4++++ b/compiler/cmm/SMRep.hs
5+@@ -100,7 +100,7 @@ bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size
6+ -- StgWord is a type representing an StgWord on the target platform.
7+ -- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform
8+ newtype StgWord = StgWord Word64
10++ deriving (Eq, Bits, Show)
12+ fromStgWord :: StgWord -> Integer
13+ fromStgWord (StgWord i) = toInteger i
14+diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
15+index e3c18b93a2..5d35db192f 100644
16+--- a/compiler/ghci/ByteCodeAsm.hs
17++++ b/compiler/ghci/ByteCodeAsm.hs
19+ -- | ByteCodeLink: Bytecode assembler and linker
21+ assembleBCOs, assembleOneBCO,
25+ SizedSeq, sizeSS, ssElts,
26+ iNTERP_STACK_CHECK_THRESH
27+@@ -30,6 +30,10 @@ import Literal
30+ import StgCmmLayout ( ArgRep(..) )
38+@@ -59,6 +63,8 @@ import Data.List
39+ import Data.Map (Map)
40+ import Data.Maybe (fromMaybe)
41+ import qualified Data.Map as Map
42++import qualified Data.ByteString as B
43++import qualified Data.ByteString.Char8 as C8
45+ -- -----------------------------------------------------------------------------
47+@@ -374,10 +380,8 @@ assembleI dflags i = case i of
48+ PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto
49+ p <- ioptr (liftM BCOPtrBCO ul_bco)
50+ emit bci_PUSH_ALTS [Op p]
51+- PUSH_ALTS_UNLIFTED proto pk
52+- -> do let ul_bco = assembleBCO dflags proto
53+- p <- ioptr (liftM BCOPtrBCO ul_bco)
54+- emit (push_alts pk) [Op p]
55++ PUSH_ALTS_UNLIFTED proto pks
56++ -> push_alts_unlifted dflags proto pks
57+ PUSH_PAD8 -> emit bci_PUSH_PAD8 []
58+ PUSH_PAD16 -> emit bci_PUSH_PAD16 []
59+ PUSH_PAD32 -> emit bci_PUSH_PAD32 []
60+@@ -435,7 +439,7 @@ assembleI dflags i = case i of
61+ JMP l -> emit bci_JMP [LabelOp l]
62+ ENTER -> emit bci_ENTER []
63+ RETURN -> emit bci_RETURN []
64+- RETURN_UBX rep -> emit (return_ubx rep) []
65++ RETURN_UBX reps -> return_ubx dflags (non_void reps)
66+ CCALL off m_addr i -> do np <- addr m_addr
67+ emit bci_CCALL [SmallOp off, Op np, SmallOp i]
68+ BRK_FUN index uniq cc -> do p1 <- ptr BCOPtrBreakArray
69+@@ -445,6 +449,7 @@ assembleI dflags i = case i of
73++ platform = targetPlatform dflags
74+ literal (LitLabel fs (Just sz) _)
75+ | platformOS (targetPlatform dflags) == OSMinGW32
76+ = litlabel (appendFS fs (mkFastString ('@':show sz)))
77+@@ -481,27 +486,100 @@ assembleI dflags i = case i of
78+ isLarge :: Word -> Bool
79+ isLarge n = n > 65535
81+-push_alts :: ArgRep -> Word16
82+-push_alts V = bci_PUSH_ALTS_V
83+-push_alts P = bci_PUSH_ALTS_P
84+-push_alts N = bci_PUSH_ALTS_N
85+-push_alts L = bci_PUSH_ALTS_L
86+-push_alts F = bci_PUSH_ALTS_F
87+-push_alts D = bci_PUSH_ALTS_D
88++push_alts :: [ArgRep] -> Maybe Word16
89++push_alts [V] = Just bci_PUSH_ALTS_V
90++push_alts [P] = Just bci_PUSH_ALTS_P
91++push_alts [N] = Just bci_PUSH_ALTS_N
92++push_alts [L] = Just bci_PUSH_ALTS_L
93++push_alts [F] = Just bci_PUSH_ALTS_F
94++push_alts [D] = Just bci_PUSH_ALTS_D
95++push_alts _ = Nothing
97+ push_alts V16 = error "push_alts: vector"
98+ push_alts V32 = error "push_alts: vector"
99+ push_alts V64 = error "push_alts: vector"
102++non_void :: [ArgRep] -> [ArgRep]
103++non_void = filter nv
107++push_alts_unlifted :: DynFlags -> ProtoBCO Name -> [ArgRep] -> Assembler ()
108++push_alts_unlifted dflags proto args = do
109++ let ul_bco = assembleBCO dflags proto
110++ p <- ioptr (liftM BCOPtrBCO ul_bco)
111++ -- fixme make proper sig
112++ case push_alts args of
113++ Just pa -> emit pa [Op p]
115++ sig <- ubx_tup_sig dflags (non_void args)
116++ emit bci_PUSH_ALTS_T [Op p, SmallOp $ fromIntegral (genericLength $ non_void args), Op sig]
118++return_ubx :: DynFlags -> [ArgRep] -> Assembler () -- Word16
120++return_ubx _ [] = emit bci_RETURN_V []
121++return_ubx _ [P] = emit bci_RETURN_P []
122++return_ubx _ [N] = emit bci_RETURN_N []
123++return_ubx _ [L] = emit bci_RETURN_L []
124++return_ubx _ [F] = emit bci_RETURN_F []
125++return_ubx _ [D] = emit bci_RETURN_D []
127++return_ubx dflags nonVoidArgs
128++ | isLarge l = panic "return_ubx: tuple too big"
130++ sig <- ubx_tup_sig dflags nonVoidArgs
131++ emit bci_RETURN_T [SmallOp $ fromIntegral l, Op sig ]
133++ l = genericLength nonVoidArgs
134++ int = words . mkLitI
135++ words ws = lit (map BCONPtrWord ws)
138+-return_ubx :: ArgRep -> Word16
139+-return_ubx V = bci_RETURN_V
140+-return_ubx P = bci_RETURN_P
141+-return_ubx N = bci_RETURN_N
142+-return_ubx L = bci_RETURN_L
143+-return_ubx F = bci_RETURN_F
144+-return_ubx D = bci_RETURN_D
145+-return_ubx V16 = error "return_ubx: vector"
146+-return_ubx V32 = error "return_ubx: vector"
147+-return_ubx V64 = error "return_ubx: vector"
148++ubx_tup_sig :: DynFlags -> [ArgRep] -> Assembler Word
149++ubx_tup_sig dflags reps = do
150++ lit [BCONPtrStr bs]
152++ (boff, posns) = assignArgumentsPos dflags 0 NativeReturn toCmm reps
153++ toCmm = primRepCmmType dflags . argToPrim
154++ bs = B.pack $ concatMap sig_bytes posns
155++ literal (LitString bs) = lit [BCONPtrStr bs]
158++sig_bytes :: (ArgRep, ParamLocation) -> [Word8]
159++sig_bytes (r, loc) = arg_byte r : loc_bytes loc
161++-- fixme do we get zeroes here?
162++loc_bytes :: ParamLocation -> [Word8]
163++loc_bytes (StackParam offset) = [1, fromIntegral offset]
164++loc_bytes (RegisterParam (VanillaReg off _)) = [2, fromIntegral off]
165++loc_bytes (RegisterParam (FloatReg off)) = [3, fromIntegral off]
166++loc_bytes (RegisterParam (DoubleReg off)) = [4, fromIntegral off]
167++loc_bytes (RegisterParam (LongReg off)) = [5, fromIntegral off]
168++loc_bytes (RegisterParam (XmmReg off)) = [6, fromIntegral off]
169++loc_bytes (RegisterParam (YmmReg off)) = [7, fromIntegral off]
170++loc_bytes (RegisterParam (ZmmReg off)) = [8, fromIntegral off]
171++loc_bytes _ = panic "GHC.ByteCode.Asm.loc_bytes"
174++arg_byte :: ArgRep -> Word8
180++arg_byte _ = panic "GHC.ByteCode.Asm.sig_byte"
183++-- we really shouldn't do this
184++argToPrim :: ArgRep -> PrimRep
185++argToPrim P = LiftedRep
186++argToPrim V = VoidRep
187++argToPrim N = WordRep -- UnliftedRep?
188++argToPrim L = Word64Rep
189++argToPrim F = FloatRep
190++argToPrim D = DoubleRep
191++argToPrim _ = panic "GHC.ByteCode.argToPrim"
193+ -- Make lists of host-sized words for literals, so that when the
194+ -- words are placed in memory at increasing addresses, the
195+diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
196+index 346add07e7..451ba50384 100644
197+--- a/compiler/ghci/ByteCodeGen.hs
198++++ b/compiler/ghci/ByteCodeGen.hs
200+ {-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
201+ {-# LANGUAGE GeneralizedNewtypeDeriving #-}
202++{-# LANGUAGE StandaloneDeriving #-}
203+ {-# OPTIONS_GHC -fprof-auto-top #-}
205+ -- (c) The University of Glasgow 2002-2006
206+@@ -75,6 +76,90 @@ import Data.Ord
207+ import GHC.Stack.CCS
208+ import Data.Either ( partitionEithers )
210++--- debug stuff, remove!
211++import qualified Var as Var
212++import qualified CostCentre
217++encodeUnique _ = "<U>"
219++-- this is a hack to be able to use pprShow in a Show instance, should be removed
220++{-# NOINLINE hackPprDflags #-}
221++hackPprDflags :: DynFlags
222++hackPprDflags = unsafeGlobalDynFlags
224++-- | replace all whitespace with space
225++fixSpace :: String -> String
226++fixSpace xs = map f xs
228++ f c | isSpace c = ' '
232++-- fixme make this more informative
233++instance Show Type where
234++ show ty = fixSpace (showPpr hackPprDflags ty)
235++instance Show CostCentre where show _ = "CostCentre"
236++instance Show CostCentre.CostCentre where show _ = "CostCentre"
237++instance Show CostCentreStack where show _ = "CostCentreStack"
238++-- instance Show StgBinderInfo where show _ = "StgBinderInfo"
239++showModule m = unitIdString (moduleUnitId m) ++ ":" ++ moduleNameString (moduleName m)
240++-- instance Show (UniqFM Id) where show u = "[" ++ show (uniqSetToList u) ++ "]"
241++instance Show TyCon where show = show . tyConName
242++instance Show Name where
243++ show n = case nameModule_maybe n of
244++ Nothing -> show (nameOccName n)
245++ Just m -> showModule m ++ "." ++ show (nameOccName n)
246++instance Show OccName where show = occNameString
247++instance Show DataCon where show d = show (dataConName d)
248++instance Show Var where show v = "(" ++ show (Var.varName v) ++ "[" ++
249++ encodeUnique (getKey (getUnique v)) ++
250++ "]" ++ if isGlobalId v then "G" else "L" ++
251++ " <" ++ show (idDetails v) ++ "> :: " ++
252++ show (Var.varType v) ++ ")"
253++instance Show IdDetails where
254++ show VanillaId = "VanillaId"
255++ show (RecSelId {}) = "RecSelId"
256++ show (DataConWorkId dc) = "DataConWorkId " ++ show dc
257++ show (DataConWrapId dc) = "DataConWrapId " ++ show dc
258++ show (ClassOpId {}) = "ClassOpId"
259++ show (PrimOpId {}) = "PrimOpId"
260++ show (FCallId {}) = "FCallId"
261++ show (TickBoxOpId {}) = "VanillaId"
262++ show (DFunId {}) = "DFunId"
263++ show CoVarId = "CoVarId"
264++ show (JoinId {}) = "JoinId"
266++-- deriving instance Show UpdateFlag
267++deriving instance Show PrimOpVecCat
268++deriving instance Show LitNumType
269++deriving instance Show Literal
270++deriving instance Show PrimOp
271++deriving instance Show AltCon
272++deriving instance Show PrimCall
273++deriving instance Show ForeignCall
274++deriving instance Show CCallTarget
275++deriving instance Show CCallSpec
276++deriving instance Show CCallConv
277++deriving instance Show FunctionOrData
279++instance Show Coercion where show co = showPpr hackPprDflags co
280++deriving instance Show LeftOrRight
281++deriving instance Show Role
282++deriving instance Show UnfoldingGuidance
283++deriving instance Show UnfoldingSource
284++instance Show elem => Show (UniqDSet elem) where
285++ show = show . uniqDSetToList
287++traceCBC :: String -> BcM ()
290++-- | otherwise = ioToBc (putStrLn msg)
294+ -- -----------------------------------------------------------------------------
295+ -- Generating byte code for a complete module
297+@@ -195,10 +280,10 @@ simpleFreeVars = freeVars
298+ type BCInstrList = OrdList BCInstr
300+ newtype ByteOff = ByteOff Int
301+- deriving (Enum, Eq, Integral, Num, Ord, Real)
302++ deriving (Enum, Eq, Show, Integral, Num, Ord, Real)
304+ newtype WordOff = WordOff Int
305+- deriving (Enum, Eq, Integral, Num, Ord, Real)
306++ deriving (Enum, Eq, Show, Integral, Num, Ord, Real)
308+ wordsToBytes :: DynFlags -> WordOff -> ByteOff
309+ wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
310+@@ -222,16 +307,14 @@ type StackDepth = ByteOff
311+ -- it after each push/pop.
312+ type BCEnv = Map Id StackDepth -- To find vars on the stack
315+-ppBCEnv :: BCEnv -> SDoc
316++ppBCEnv :: HasDebugCallStack => BCEnv -> SDoc
319+ $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
322+- pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
323++ pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)
324+ cmp_snd x y = compare (snd x) (snd y)
327+ -- Create a BCO and do a spot of peephole optimisation on the insns
328+ -- at the same time.
329+@@ -315,7 +398,7 @@ schemeTopBind (id, rhs)
330+ -- because mkConAppCode treats nullary constructor applications
331+ -- by just re-using the single top-level definition. So
332+ -- for the worker itself, we must allocate it directly.
333+- -- ioToBc (putStrLn $ "top level BCO")
334++ traceCBC "top level BCO"
335+ emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
336+ (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
338+@@ -341,17 +424,23 @@ schemeR :: [Id] -- Free vars of the RHS, ordered as they
339+ -> (Id, AnnExpr Id DVarSet)
340+ -> BcM (ProtoBCO Name)
341+ schemeR fvs (nm, rhs)
343+- | trace (showSDoc (
344++{- | trace (showSDoc (
346+ $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
347+ $$ pprCoreExpr (deAnnotate rhs)
353+- = schemeR_wrk fvs nm rhs (collect rhs)
356++ dflags <- getDynFlags
357++ traceCBC ("schemeR:\n" ++ showSDoc dflags (
359++ $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
360++ $$ pprCoreExpr (deAnnotate rhs)
363++ schemeR_wrk fvs nm rhs (collect rhs)
365+ -- If an expression is a lambda (after apply bcView), return the
366+ -- list of arguments to the lambda (in R-to-L order) and the
367+@@ -466,7 +555,8 @@ fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
372++ :: HasDebugCallStack
376+ -> AnnExpr' Id DVarSet
377+@@ -479,7 +569,26 @@ returnUnboxedAtom d s p e e_rep = do
378+ (push, szb) <- pushAtom d p e
379+ return (push -- value onto stack
380+ `appOL` mkSlideB dflags szb (d - s) -- clear to sequel
381+- `snocOL` RETURN_UBX e_rep) -- go
382++ `snocOL` RETURN_UBX [e_rep]) -- go
385++ :: HasDebugCallStack
389++ -> [AnnExpr' Id DVarSet]
392++-- Returning an unlifted value.
393++-- Heave it on the stack, SLIDE, and RETURN.
394++returnUnboxedAtomT d s p es e_reps = do
395++ dflags <- getDynFlags
396++ let platform = targetPlatform dflags
397++ (pushes, szbs) <- unzip <$> mapM (\(off, a) -> pushAtom (d+wordsToBytes dflags off) p a) (zip [0..] es)
398++ traceCBC ("returnUnboxedAtomT:\nl: " ++ show (length e_reps) ++ " " ++ show szbs)
399++ return (mconcat pushes -- value onto stack
400++ `appOL` mkSlideB dflags (sum szbs) (d - s) -- clear to sequel
401++ `snocOL` RETURN_UBX e_reps) -- go
403+ -- Compile code to apply the given expression to the remaining args
404+ -- on the stack, returning a HNF.
405+@@ -501,7 +610,7 @@ schemeE d s p e@(AnnVar v)
406+ AnnApp (bogus_fvs, AnnVar (protectLPJoinPointId v))
407+ (bogus_fvs, AnnVar voidPrimId)
408+ -- schemeT will call splitApp, dropping the fvs.
410++ | isUnboxedTupleType (idType v) = returnUnboxedAtomT d s p [e] (bcIdArgReps v) -- fixme split tuple? yup! BUG BUG BUG!
411+ | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
412+ | otherwise = schemeT d s p e
414+@@ -772,7 +881,8 @@ Right Fix is to take advantage of join points as goto-labels.
415+ -- 4. Otherwise, it must be a function call. Push the args
416+ -- right to left, SLIDE and ENTER.
418+-schemeT :: StackDepth -- Stack depth
419++schemeT :: HasDebugCallStack
420++ => StackDepth -- Stack depth
421+ -> Sequel -- Sequel depth
422+ -> BCEnv -- stack env
423+ -> AnnExpr' Id DVarSet
424+@@ -795,11 +905,12 @@ schemeT d s p app
425+ | Just con <- maybe_saturated_dcon
426+ , isUnboxedTupleCon con
427+ = case args_r_to_l of
428++ {- special cases should be handled by general now
429+ [arg1,arg2] | isVAtom arg1 ->
430+ unboxedTupleReturn d s p arg2
431+ [arg1,arg2] | isVAtom arg2 ->
432+- unboxedTupleReturn d s p arg1
433+- _other -> multiValException
434++ unboxedTupleReturn d s p arg1 -}
435++ other -> genericUnboxedTupleReturn d s p other
437+ -- Case 3: Ordinary data constructor
438+ | Just con <- maybe_saturated_dcon
439+@@ -832,7 +943,8 @@ schemeT d s p app
440+ -- leaving it on top of the stack
444++ :: HasDebugCallStack
448+ -> DataCon -- The data constructor
449+@@ -883,14 +995,22 @@ mkConAppCode orig_d _ p con args_r_to_l =
450+ -- returned, even if it is a pointed type. We always just return.
453+- :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
454++ :: HasDebugCallStack => StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
455+ unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
457++genericUnboxedTupleReturn
458++ :: HasDebugCallStack => StackDepth -> Sequel -> BCEnv -> [AnnExpr' Id DVarSet] -> BcM BCInstrList
459++genericUnboxedTupleReturn d s p args =
460++ returnUnboxedAtomT d s p args (map atomRep args)
461++ -- panic "genericUnboxedTupleReturn"
464+ -- -----------------------------------------------------------------------------
465+ -- Generate code for a tail-call
469++ :: HasDebugCallStack
474+@@ -951,7 +1071,8 @@ findPushSeq _
479++ :: HasDebugCallStack
483+ -> AnnExpr Id DVarSet
484+@@ -961,9 +1082,6 @@ doCase
485+ -- don't enter the result
487+ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
488+- | typePrimRep (idType bndr) `lengthExceeds` 1
489+- = multiValException
492+ dflags <- getDynFlags
494+@@ -982,6 +1100,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
495+ save_ccs_size_b | profiling = 2 * wordSize dflags
498++ bndr_size = wordsToBytes dflags (idSizeW dflags bndr)
499+ -- An unlifted value gets an extra info table pushed on top
500+ -- when it is returned.
501+ unlifted_itbl_size_b :: StackDepth
502+@@ -990,7 +1109,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
504+ -- depth of stack after the return value has been pushed
506+- d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
507++ d + ret_frame_size_b + bndr_size -- wordsToBytes dflags (idSizeW dflags bndr)
509+ -- depth of stack after the extra info table for an unboxed return
510+ -- has been pushed, if any. This is the stack depth at the
511+@@ -1018,11 +1137,24 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
512+ | null real_bndrs = do
513+ rhs_code <- schemeE d_alts s p_alts rhs
514+ return (my_discr alt, rhs_code)
515+- -- If an alt attempts to match on an unboxed tuple or sum, we must
516+- -- bail out, as the bytecode compiler can't handle them.
517+- -- (See Trac #14608.)
518+- | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
519+- = multiValException
520++ | isUnboxedTupleType bndr_ty =
521++ let (tot_wds, _ptrs_wds, args_offsets) =
522++ mkVirtHeapOffsets dflags NoHeader
523++ [ NonVoid (bcIdPrimRep id, id)
524++ | NonVoid id <- nonVoidIds real_bndrs
527++ stack_bot = d_alts -- + wordsToBytes platform size
528++ tuple_start = d_bndr -- stack_bot - wordsToBytes platform (WordOff tot_wds + 1)
530++ p' = Map.insertList
531++ [ (arg, tuple_start - ByteOff offset)
532++ | (NonVoid arg, offset) <- args_offsets ]
535++ traceCBC ("ubx tup cont: " ++ show (stack_bot,tuple_start,tot_wds) ++ "\n" ++ show args_offsets)
536++ rhs_code <- schemeE stack_bot s p' rhs
537++ return (NoDiscr, rhs_code)
538+ -- algebraic alt with some binders
540+ let (tot_wds, _ptrs_wds, args_offsets) =
541+@@ -1050,7 +1182,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
542+ my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
543+ my_discr (DataAlt dc, _, _)
544+ | isUnboxedTupleCon dc || isUnboxedSumCon dc
545+- = multiValException
548+ = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
549+ my_discr (LitAlt l, _, _)
550+@@ -1092,7 +1224,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
551+ -- NB: unboxed tuple cases bind the scrut binder to the same offset
552+ -- as one of the alt binders, so we have to remove any duplicates here:
553+ rel_slots = nub $ map fromIntegral $ concat (map spread binds)
554+- spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
555++ spread (id, offset) | isUnboxedTupleType (idType id) = []
556++ | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
558+ where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
560+@@ -1103,8 +1236,14 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
561+ alt_bco_name = getName bndr
562+ alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
563+ 0{-no arity-} bitmap_size bitmap True{-is alts-}
564+--- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
565+--- "\n bitmap = " ++ show bitmap) $ do
567++ "case: bndr = " ++ showSDocDebug dflags (ppr bndr) ++
568++ "\nbndr_size = " ++ show bndr_size ++
569++ "\ndepth = " ++ show d ++
570++ "\nenv = \n" ++ showSDocDebug dflags (ppBCEnv p) ++
571++ "\n bitmap = " ++ show bitmap ++
572++ "\n ret_frame_size = " ++ show ret_frame_size_b
575+ scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
576+ (d + ret_frame_size_b + save_ccs_size_b)
577+@@ -1112,7 +1251,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
578+ alt_bco' <- emitBc alt_bco
580+ | isAlgCase = PUSH_ALTS alt_bco'
581+- | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
582++ | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgReps bndr_ty)
583+ return (push_alts `consOL` scrut_code)
586+@@ -1328,7 +1467,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
588+ d_after_r_min_s = bytesToWords dflags (d_after_r - s)
589+ wrapup = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
590+- `snocOL` RETURN_UBX (toArgRep r_rep)
591++ `snocOL` RETURN_UBX [toArgRep r_rep]
592+ --trace (show (arg1_offW, args_offW , (map argRepSizeW a_reps) )) $
595+@@ -1461,7 +1600,8 @@ a 1-word null. See Trac #8383.
600++ :: HasDebugCallStack
604+ -> AnnExpr' Id DVarSet
605+@@ -1512,7 +1652,7 @@ implement_tagToId d s p arg names
606+ -- depth 6 stack has valid words 0 .. 5.
609+- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
610++ :: HasDebugCallStack => StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
612+ | Just e' <- bcView e
614+@@ -1608,7 +1748,7 @@ pushAtom _ _ expr
615+ -- This is slightly different to @pushAtom@ due to the fact that we allow
616+ -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
618+- :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
619++ :: HasDebugCallStack => StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
621+ pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =
622+ return (unitOL (PUSH_UBX32 lit), 4)
623+@@ -1628,7 +1768,7 @@ pushConstrAtom d p (AnnVar v)
625+ pushConstrAtom d p expr = pushAtom d p expr
627+-pushPadding :: Int -> (BCInstrList, ByteOff)
628++pushPadding :: HasDebugCallStack => Int -> (BCInstrList, ByteOff)
629+ pushPadding !n = go n (nilOL, 0)
631+ go n acc@(!instrs, !off) = case n of
632+@@ -1644,7 +1784,8 @@ pushPadding !n = go n (nilOL, 0)
633+ -- of making a multiway branch using a switch tree.
634+ -- What a load of hassle!
636+-mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt
637++mkMultiBranch :: HasDebugCallStack
638++ => Maybe Int -- # datacons in tycon, if alg alt
639+ -- a hint; generates better code
640+ -- Nothing is always safe
641+ -> [(Discr, BCInstrList)]
642+@@ -1780,22 +1921,30 @@ instance Outputable Discr where
643+ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
644+ lookupBCEnv_maybe = Map.lookup
646+-idSizeW :: DynFlags -> Id -> WordOff
647+-idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
648++idSizeW :: HasDebugCallStack => DynFlags -> Id -> WordOff
649++idSizeW platform = WordOff . sum . map (argRepSizeW platform) . bcIdArgReps
651+-idSizeCon :: DynFlags -> Id -> ByteOff
652+-idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
653++-- fixme this doesn't widen stuff to word width
654++idSizeCon :: HasDebugCallStack => DynFlags -> Id -> ByteOff
655++-- idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
656++idSizeCon dflags = ByteOff . sum . map (primRepSizeB dflags) . bcIdPrimReps
658+-bcIdArgRep :: Id -> ArgRep
659++bcIdArgRep :: HasDebugCallStack => Id -> ArgRep
660+ bcIdArgRep = toArgRep . bcIdPrimRep
662+-bcIdPrimRep :: Id -> PrimRep
663++bcIdPrimRep :: HasDebugCallStack => Id -> PrimRep
665+ | [rep] <- typePrimRepArgs (idType id)
668+ = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
670++bcIdArgReps :: HasDebugCallStack => Id -> [ArgRep]
671++bcIdArgReps = map toArgRep . bcIdPrimReps
673++bcIdPrimReps :: HasDebugCallStack => Id -> [PrimRep]
674++bcIdPrimReps id = typePrimRepArgs (idType id)
676+ repSizeWords :: DynFlags -> PrimRep -> WordOff
677+ repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
679+@@ -1808,8 +1957,9 @@ isVoidArg V = True
683+-multiValException :: a
684+-multiValException = throwGhcException (ProgramError
685++multiValException :: HasCallStack => a
686++multiValException = -- throwGhcException (ProgramError
687++ pprPanic "multiValException" (text
688+ ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
689+ " Possibly due to foreign import/export decls in source.\n"++
690+ " Workaround: use -fobject-code, or compile this module to .o separately."))
691+@@ -1857,7 +2007,7 @@ splitApp (AnnApp (_,f) (_,a)) = case splitApp f of
692+ splitApp e = (e, [])
695+-bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
696++bcView :: HasDebugCallStack => AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
697+ -- The "bytecode view" of a term discards
698+ -- a) type abstractions
699+ -- b) type applications
700+@@ -1878,7 +2028,7 @@ isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
701+ isVAtom (AnnCoercion {}) = True
704+-atomPrimRep :: AnnExpr' Id ann -> PrimRep
705++atomPrimRep :: HasDebugCallStack => AnnExpr' Id ann -> PrimRep
706+ atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
707+ atomPrimRep (AnnVar v) = bcIdPrimRep v
708+ atomPrimRep (AnnLit l) = typePrimRep1 (literalType l)
709+@@ -1890,7 +2040,7 @@ atomPrimRep (AnnCase _ _ ty _) = ASSERT(typePrimRep ty == [LiftedRep]) Lift
710+ atomPrimRep (AnnCoercion {}) = VoidRep
711+ atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
713+-atomRep :: AnnExpr' Id ann -> ArgRep
714++atomRep :: HasDebugCallStack => AnnExpr' Id ann -> ArgRep
715+ atomRep e = toArgRep (atomPrimRep e)
717+ -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
718+@@ -1899,9 +2049,13 @@ atomRep e = toArgRep (atomPrimRep e)
719+ mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
720+ mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
722+-typeArgRep :: Type -> ArgRep
723++typeArgRep :: HasDebugCallStack => Type -> ArgRep
724+ typeArgRep = toArgRep . typePrimRep1
726++typeArgReps :: HasDebugCallStack => Type -> [ArgRep]
727++typeArgReps = map toArgRep . typePrimRepArgs -- typePrimRepArgs (idType id)
730+ -- -----------------------------------------------------------------------------
731+ -- The bytecode generator's monad
733+diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
734+index d405e1ade7..debe4672e4 100644
735+--- a/compiler/ghci/ByteCodeInstr.hs
736++++ b/compiler/ghci/ByteCodeInstr.hs
737+@@ -86,7 +86,7 @@ data BCInstr
739+ -- Push an alt continuation
740+ | PUSH_ALTS (ProtoBCO Name)
741+- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
742++ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) [ArgRep]
744+ -- Pushing 8, 16 and 32 bits of padding (for constructors).
746+@@ -169,8 +169,8 @@ data BCInstr
748+ -- To Infinity And Beyond
750+- | RETURN -- return a lifted value
751+- | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
752++ | RETURN -- return a lifted value
753++ | RETURN_UBX [ArgRep] -- return an unlifted value, here's its rep
756+ | BRK_FUN Word16 Unique (RemotePtr CostCentre)
757+diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
758+index e5d55f694f..c42476a201 100644
759+--- a/includes/rts/Bytecodes.h
760++++ b/includes/rts/Bytecodes.h
762+ #define bci_BRK_FUN 66
763+ #define bci_TESTLT_W 67
764+ #define bci_TESTEQ_W 68
766++#define bci_RETURN_T 70
767++#define bci_PUSH_ALTS_T 71
768+ /* If you need to go past 255 then you will run into the flags */
770+ /* If you need to go below 0x0100 then you will run into the instructions */
771+diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
772+index 8c4cb9fc8c..ee4c990ca8 100644
773+--- a/includes/stg/MiscClosures.h
774++++ b/includes/stg/MiscClosures.h
775+@@ -86,6 +86,18 @@ RTS_RET(stg_ctoi_F1);
776+ RTS_RET(stg_ctoi_D1);
777+ RTS_RET(stg_ctoi_L1);
778+ RTS_RET(stg_ctoi_V);
779++RTS_RET(stg_ctoi_T);
781++RTS_RET(stg_save_R1_p);
782++RTS_RET(stg_save_R2_p);
783++RTS_RET(stg_save_R3_p);
784++RTS_RET(stg_save_R1_n);
785++RTS_RET(stg_save_R2_n);
786++RTS_RET(stg_save_R3_n);
787++RTS_RET(stg_save_D1);
788++RTS_RET(stg_save_D2);
789++RTS_RET(stg_save_F1);
790++RTS_RET(stg_save_F2);
792+ RTS_RET(stg_apply_interp);
794+diff --git a/rts/Disassembler.c b/rts/Disassembler.c
795+index 01d6c3b1d9..1afbe0aea2 100644
796+--- a/rts/Disassembler.c
797++++ b/rts/Disassembler.c
798+@@ -148,6 +148,13 @@ disInstr ( StgBCO *bco, int pc )
799+ debugBelch("PUSH_ALTS_V " ); printPtr( ptrs[instrs[pc]] );
802++ case bci_PUSH_ALTS_T:
803++ // fixme final size of instruction
804++ debugBelch("PUSH_ALTS_T "); printPtr( ptrs[instrs[pc]] );
805++ debugBelch(" %d ", instrs[pc+1]);
806++ printTupleSig(literals[instrs[pc+2]]);
810+ debugBelch("PUSH_PAD8\n");
812+@@ -313,7 +320,14 @@ disInstr ( StgBCO *bco, int pc )
814+ debugBelch("RETURN_V\n" );
818++ // fixme update for final size of return_t instr
819++ // fixme indirection to literals?
820++ debugBelch("RETURN_T %d ", instrs[pc]);
821++ printTupleSig( literals[instrs[pc+1]] );
826+ barf("disInstr: unknown opcode %u", (unsigned int) instr);
828+diff --git a/rts/Interpreter.c b/rts/Interpreter.c
829+index 2d68a1ce3a..91ac83c445 100644
830+--- a/rts/Interpreter.c
831++++ b/rts/Interpreter.c
832+@@ -364,6 +364,10 @@ interpretBCO (Capability* cap)
833+ // do_return_unboxed, below.
836++ IF_DEBUG(interpreter,
837++ debugBelch("warning: do_return_unboxed unhandled case\n");
840+ goto do_return_unboxed;
843+@@ -673,35 +677,71 @@ do_return:
847++ // debugBelch("returning unboxed\n");
850+- ASSERT( SpW(0) == (W_)&stg_ret_v_info
852++ if(SpW(0) == (W_)&stg_ret_v_info
853+ || SpW(0) == (W_)&stg_ret_p_info
854+ || SpW(0) == (W_)&stg_ret_n_info
855+ || SpW(0) == (W_)&stg_ret_f_info
856+ || SpW(0) == (W_)&stg_ret_d_info
857+ || SpW(0) == (W_)&stg_ret_l_info
860++ IF_DEBUG(interpreter,
861++ debugBelch("normal unboxed return\n");
866++ IF_DEBUG(interpreter,
867++ debugBelch("tuple unboxed return size %d\n", ubx_tup);
871+ IF_DEBUG(interpreter,
873+ "\n---------------------------------------------------------------\n");
874+- debugBelch("Returning: "); printObj(obj);
875++ debugBelch("Returning unboxed x: "); // printObj(obj);
876+ debugBelch("Sp = %p\n", Sp);
877+ #if defined(PROFILING)
878+ fprintCCS(stderr, cap->r.rCCCS);
882+- printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
883++ debugBelch("printing stack chunk\n");
885++ printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size);
890++ IF_DEBUG(interpreter,
891++ debugBelch("before offset\n");
894+ // get the offset of the stg_ctoi_ret_XXX itbl
895+- offset = stack_frame_sizeW((StgClosure *)Sp);
896++ // fixme changed to after return!
898++ offset = ubx_tup + 1;
900++ offset = stack_frame_sizeW((StgClosure *)Sp);
902++ /* if(bci == bci_RETURN_T) {
903++ debugBelch("unboxed tuple, adjusting offset\n");
906++ // yeah it crashes here
907++ IF_DEBUG(interpreter,
908++ debugBelch("offset: %d\n", offset);
912+ switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
914++ IF_DEBUG(interpreter,
915++ debugBelch("got itable\n");
919+ // Returning to an interpreted continuation: put the object on
920+ // the stack, and start executing the BCO.
921+@@ -988,16 +1028,16 @@ run_BCO:
922+ ASSERT(bciPtr < bcoSize);
923+ IF_DEBUG(interpreter,
924+ //if (do_print_stack) {
925+- //debugBelch("\n-- BEGIN stack\n");
926+- //printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
927+- //debugBelch("-- END stack\n\n");
928++ // debugBelch("\n-- BEGIN stack\n");
929++ // printStack(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size,iSu);
930++ // debugBelch("-- END stack\n\n");
932+ debugBelch("Sp = %p pc = %-4d ", Sp, bciPtr);
933+ disInstr(bco,bciPtr);
937+- for (i = 8; i >= 0; i--) {
938+- debugBelch("%d %p\n", i, (void *) SpW(i));
939++ for (i = 42; i >= 0; i--) {
940++ debugBelch("%d %p (%ld)\n", i, (void *) SpW(i), SpW(i));
944+@@ -1326,6 +1366,22 @@ run_BCO:
948++ case bci_PUSH_ALTS_T: {
949++ int o_bco = BCO_GET_LARGE_ARG;
950++ int size = BCO_NEXT;
951++ char* lit = literals[BCO_GET_LARGE_ARG];
952++ /* fixme push shape on stack? */
953++ SpW(-2) = (W_)&stg_ctoi_T_info; /* fixme */
954++ SpW(-1) = BCO_PTR(o_bco);
956++#if defined(PROFILING)
958++ SpW(1) = (W_)cap->r.rCCCS;
959++ SpW(0) = (W_)&stg_restore_cccs_info;
964+ case bci_PUSH_APPLY_N:
965+ Sp_subW(1); SpW(0) = (W_)&stg_ap_n_info;
967+@@ -1705,6 +1761,16 @@ run_BCO:
969+ SpW(0) = (W_)&stg_ret_v_info;
970+ goto do_return_unboxed;
971++ case bci_RETURN_T: {
972++ // fixme should we fix to large args for tuples if needed?
973++ int size = BCO_NEXT; // BCO_GET_LARGE_ARG;
974++ char* shape = literals[BCO_GET_LARGE_ARG];
975++ // debugBelch("returning unboxed tup size: %d\n", size);
977++ SpW(0) = size; // fixme have proper frame here
979++ goto do_return_unboxed;
983+ int stkoff = BCO_NEXT;
984+diff --git a/rts/Printer.c b/rts/Printer.c
985+index 291f529e8f..56380f0b26 100644
988+@@ -646,6 +646,20 @@ void printTSO( StgTSO *tso )
989+ printStack( tso->stackobj );
993++void printTupleSig ( const unsigned char* sig)
995++ const char* arg_tys = "_PNLFD";
996++ const char* loc_tys = "_SRFDLXYZ";
998++ int arg_ty = (int)sig[0];
999++ int loc_ty = (int)sig[1];
1000++ int off = (int)sig[2];
1001++ debugBelch("%c%c%d ", arg_tys[arg_ty], loc_tys[loc_ty], off);
1006+ /* --------------------------------------------------------------------------
1007+ * Address printing code
1009+diff --git a/rts/Printer.h b/rts/Printer.h
1010+index d2eaf010c6..5f571b3f17 100644
1015+ extern void printPtr ( StgPtr p );
1016+ extern void printObj ( StgClosure *obj );
1018+ extern const char * closure_type_names[];
1020+ void info_hdr_type ( const StgClosure *closure, char *res );
1021+diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
1022+index e80ce45172..50b47771ad 100644
1023+--- a/rts/StgMiscClosures.cmm
1024++++ b/rts/StgMiscClosures.cmm
1025+@@ -195,6 +195,102 @@ INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
1026+ jump stg_yield_to_interpreter [];
1030++ * When the returned value is an unboxed tuple
1032++INFO_TABLE_RET( stg_ctoi_T, RET_BCO )
1033++ /* explicit stack */
1036++ jump stg_yield_to_interpreter [];
1039++INFO_TABLE_RET ( stg_save_R1_p, RET_BCO )
1042++ Sp(0) = stg_ret_p_info;
1044++ jump %ENTRY_CODE(Sp(0)) [*];
1047++INFO_TABLE_RET ( stg_save_R2_p, RET_BCO )
1050++ Sp(0) = stg_ret_p_info;
1052++ jump %ENTRY_CODE(Sp(0)) [*];
1056++INFO_TABLE_RET ( stg_save_R3_p, RET_BCO )
1059++ Sp(0) = stg_ret_p_info;
1061++ jump %ENTRY_CODE(Sp(0)) [*];
1064++INFO_TABLE_RET ( stg_save_R1_n, RET_BCO )
1067++ Sp(0) = stg_ret_n_info;
1069++ jump %ENTRY_CODE(Sp(0)) [*];
1072++INFO_TABLE_RET ( stg_save_R2_n, RET_BCO )
1075++ Sp(0) = stg_ret_n_info;
1077++ jump %ENTRY_CODE(Sp(0)) [*];
1081++INFO_TABLE_RET ( stg_save_R3_n, RET_BCO )
1084++ Sp(0) = stg_ret_n_info;
1086++ jump %ENTRY_CODE(Sp(0)) [*];
1089++INFO_TABLE_RET ( stg_save_D1, RET_BCO )
1091++ // check offset for 64 bit
1092++ // Sp_adj(-1) - SIZEOF_DOUBLE;
1094++ D_[Sp + WDS(1)] = D1;
1095++ Sp(0) = stg_ret_d_info;
1097++ jump %ENTRY_CODE(Sp(0)) [*];
1100++INFO_TABLE_RET ( stg_save_D2, RET_BCO )
1102++ D_[Sp + WDS(1)] = D2;
1103++ Sp(0) = stg_ret_d_info;
1105++ jump %ENTRY_CODE(Sp(0)) [*];
1108++INFO_TABLE_RET ( stg_save_F1, RET_BCO )
1110++ F_[Sp + WDS(1)] = F1;
1111++ Sp(0) = stg_ret_f_info;
1113++ jump %ENTRY_CODE(Sp(0)) [*];
1116++INFO_TABLE_RET ( stg_save_F2, RET_BCO )
1118++ F_[Sp + WDS(1)] = F2;
1119++ Sp(0) = stg_ret_f_info;
1121++ jump %ENTRY_CODE(Sp(0)) [*];
1126+ * Dummy info table pushed on the top of the stack when the interpreter
1127+ * should apply the BCO on the stack to its arguments, also on the