Implement unboxed sum primitive type
[ghc.git] / compiler / ghci / ByteCodeGen.hs
index fc72084..9c7d25a 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -31,6 +31,8 @@ import Literal
 import PrimOp
 import CoreFVs
 import Type
+import RepType
+import Kind            ( isLiftedTypeKind )
 import DataCon
 import TyCon
 import Util
@@ -44,27 +46,25 @@ import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
 import SMRep
 import Bitmap
 import OrdList
+import Maybes
 
 import Data.List
 import Foreign
-
-#if __GLASGOW_HASKELL__ < 709
-import Control.Applicative (Applicative(..))
-#endif
 import Control.Monad
 import Data.Char
 
 import UniqSupply
-import BreakArray
-import Data.Maybe
 import Module
 import Control.Arrow ( second )
 
 import Data.Array
 import Data.Map (Map)
+import Data.IntMap (IntMap)
 import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
 import qualified FiniteMap as Map
 import Data.Ord
+import GHC.Stack.CCS
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module
@@ -73,18 +73,19 @@ byteCodeGen :: HscEnv
             -> Module
             -> CoreProgram
             -> [TyCon]
-            -> ModBreaks
+            -> Maybe ModBreaks
             -> IO CompiledByteCode
-byteCodeGen hsc_env this_mod binds tycs modBreaks
-   = do let dflags = hsc_dflags hsc_env
-        showPass dflags "ByteCodeGen"
-
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
+   = withTiming (pure dflags)
+                (text "ByteCodeGen"<+>brackets (ppr this_mod))
+                (const ()) $ do
         let flatBinds = [ (bndr, simpleFreeVars rhs)
                         | (bndr, rhs) <- flattenBinds binds]
 
         us <- mkSplitUniqSupply 'y'
-        (BcM_State _hsc_env _us _this_mod _final_ctr ffis _, proto_bcos)
-           <- runBc hsc_env us this_mod modBreaks (mapM schemeTopBind flatBinds)
+        (BcM_State{..}, proto_bcos) <-
+           runBc hsc_env us this_mod mb_modBreaks $
+             mapM schemeTopBind flatBinds
 
         when (notNull ffis)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -93,20 +94,23 @@ byteCodeGen hsc_env this_mod binds tycs modBreaks
            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
         assembleBCOs hsc_env proto_bcos tycs
+          (case modBreaks of
+             Nothing -> Nothing
+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+  where dflags = hsc_dflags hsc_env
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for an expression
 
--- Returns: (the root BCO for this expression,
---           a list of auxilary BCOs resulting from compiling closures)
+-- Returns: the root BCO for this expression
 coreExprToBCOs :: HscEnv
                -> Module
                -> CoreExpr
                -> IO UnlinkedBCO
 coreExprToBCOs hsc_env this_mod expr
- = do let dflags = hsc_dflags hsc_env
-      showPass dflags "ByteCodeGen"
-
+ = withTiming (pure dflags)
+              (text "ByteCodeGen"<+>brackets (ppr this_mod))
+              (const ()) $ do
       -- create a totally bogus name for the top-level BCO; this
       -- should be harmless, since it's never used for anything
       let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
@@ -115,8 +119,8 @@ coreExprToBCOs hsc_env this_mod expr
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
-         <- runBc hsc_env us this_mod emptyModBreaks $
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
+         <- runBc hsc_env us this_mod Nothing $
               schemeTopBind (invented_id, simpleFreeVars expr)
 
       when (notNull mallocd)
@@ -124,8 +128,8 @@ coreExprToBCOs hsc_env this_mod expr
 
       dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
 
-      assembleBCO dflags proto_bco
-
+      assembleOneBCO hsc_env proto_bco
+  where dflags = hsc_dflags hsc_env
 
 -- The regular freeVars function gives more information than is useful to
 -- us here. simpleFreeVars does the impedence matching.
@@ -286,7 +290,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -300,8 +304,8 @@ collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
     go xs (AnnLam x (_,e))
-      | UbxTupleRep _ <- repType (idType x)
-      = unboxedTupleException
+      | repTypeArgs (idType x) `lengthExceeds` 1
+      = multiValException
       | otherwise
       = go (x:xs) e
     go xs not_lambda = (reverse xs, not_lambda)
@@ -335,22 +339,18 @@ schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
   | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
   = do  code <- schemeE (fromIntegral d) 0 p newRhs
-        flag_arr <- getBreakArray
         cc_arr <- getCCArray
-        this_mod <- getCurrentModule
+        this_mod <- moduleName <$> getCurrentModule
         let idOffSets = getVarOffSets d p fvs
-        let breakInfo = BreakInfo
-                        { breakInfo_module = this_mod
-                        , breakInfo_number = tick_no
-                        , breakInfo_vars = idOffSets
-                        , breakInfo_resty = exprType (deAnnotate' newRhs)
+        let breakInfo = CgBreakInfo
+                        { cgb_vars = idOffSets
+                        , cgb_resty = exprType (deAnnotate' newRhs)
                         }
+        newBreakInfo tick_no breakInfo
         dflags <- getDynFlags
         let cc | interpreterProfiled dflags = cc_arr ! tick_no
                | otherwise = toRemotePtr nullPtr
-        let breakInstr = case flag_arr of
-                         BA arr# ->
-                             BRK_FUN arr# (fromIntegral tick_no) breakInfo cc
+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
         return $ breakInstr `consOL` code
    | otherwise = schemeE (fromIntegral d) 0 p rhs
 
@@ -412,7 +412,7 @@ schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (litera
 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
 
 schemeE d s p e@(AnnVar v)
-    | isUnLiftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
     | otherwise                 = schemeT d s p e
 
 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
@@ -484,35 +484,47 @@ schemeE d s p (AnnLet binds (_,body)) = do
      thunk_codes <- sequence compile_binds
      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
 
--- introduce a let binding for a ticked case expression. This rule
+-- Introduce a let binding for a ticked case expression. This rule
 -- *should* only fire when the expression was not already let-bound
 -- (the code gen for let bindings should take care of that).  Todo: we
 -- call exprFreeVars on a deAnnotated expression, this may not be the
 -- best way to calculate the free vars but it seemed like the least
 -- intrusive thing to do
 schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-   = if isUnLiftedType ty
-        then do
-          -- If the result type is unlifted, then we must generate
+   | isLiftedTypeKind (typeKind ty)
+   = do   id <- newId ty
+          -- Todo: is emptyVarSet correct on the next line?
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
+          schemeE d s p letExp
+
+   | otherwise
+   = do   -- If the result type is not definitely lifted, then we must generate
           --   let f = \s . tick<n> e
           --   in  f realWorld#
           -- When we stop at the breakpoint, _result will have an unlifted
           -- type and hence won't be bound in the environment, but the
           -- breakpoint will otherwise work fine.
+          --
+          -- NB (Trac #12007) this /also/ applies for if (ty :: TYPE r), where
+          --    r :: RuntimeRep is a variable. This can happen in the
+          --    continuations for a pattern-synonym matcher
+          --    match = /\(r::RuntimeRep) /\(a::TYPE r).
+          --            \(k :: Int -> a) \(v::T).
+          --            case v of MkV n -> k n
+          -- Here (k n) :: a :: Type r, so we don't know if it's lifted
+          -- or not; but that should be fine provided we add that void arg.
+
           id <- newId (mkFunTy realWorldStatePrimTy ty)
           st <- newId realWorldStatePrimTy
           let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
                               (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
                                                     (emptyDVarSet, AnnVar realWorldPrimId)))
           schemeE d s p letExp
-        else do
-          id <- newId ty
-          -- Todo: is emptyVarSet correct on the next line?
-          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
-          schemeE d s p letExp
-   where exp' = deAnnotate' exp
-         fvs  = exprFreeVarsDSet exp'
-         ty   = exprType exp'
+
+   where
+     exp' = deAnnotate' exp
+     fvs  = exprFreeVarsDSet exp'
+     ty   = exprType exp'
 
 -- ignore other kinds of tick
 schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
@@ -521,54 +533,37 @@ schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
         -- no alts: scrut is guaranteed to diverge
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc
-   , UnaryRep rep_ty1 <- repType (idType bind1), UnaryRep rep_ty2 <- repType (idType bind2)
+   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
+   , [rep_ty1] <- repTypeArgs (idType bind1)
+   , [rep_ty2] <- repTypeArgs (idType bind2)
         -- Convert
         --      case .... of x { (# V'd-thing, a #) -> ... }
         -- to
         --      case .... of a { DEFAULT -> ... }
-        -- becuse the return convention for both are identical.
+        -- because the return convention for both are identical.
         --
         -- Note that it does not matter losing the void-rep thing from the
         -- envt (it won't be bound now) because we never look such things up.
    , Just res <- case () of
-                   _ | VoidRep <- typePrimRep rep_ty1
-                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                     | VoidRep <- typePrimRep rep_ty2
-                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
+                   _ | isVoidTy rep_ty1 && not (isVoidTy rep_ty2)
+                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
+                     | isVoidTy rep_ty2 && not (isVoidTy rep_ty1)
+                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
                      | otherwise
                      -> Nothing
    = res
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
-   | isUnboxedTupleCon dc, UnaryRep _ <- repType (idType bind1)
-        -- Similarly, convert
-        --      case .... of x { (# a #) -> ... }
-        -- to
-        --      case .... of a { DEFAULT -> ... }
-   = --trace "automagic mashing of case alts (# a #)"  $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-
-schemeE d s p (AnnCase scrut bndr _ [(DEFAULT, [], rhs)])
-   | Just (tc, tys) <- splitTyConApp_maybe (idType bndr)
-   , isUnboxedTupleTyCon tc
-   , Just res <- case tys of
-        [ty]       | UnaryRep _ <- repType ty
-                   , let bind = bndr `setIdType` ty
-                   -> Just $ doCase d s p scrut bind [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-        [ty1, ty2] | UnaryRep rep_ty1 <- repType ty1
-                   , UnaryRep rep_ty2 <- repType ty2
-                   -> case () of
-                       _ | VoidRep <- typePrimRep rep_ty1
-                         , let bind2 = bndr `setIdType` ty2
-                         -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                         | VoidRep <- typePrimRep rep_ty2
-                         , let bind1 = bndr `setIdType` ty1
-                         -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr){-unboxed tuple-}
-                         | otherwise
-                         -> Nothing
-        _ -> Nothing
-   = res
+   | isUnboxedTupleCon dc
+   , repTypeArgs (idType bndr) `lengthIs` 1 -- handles unit tuples
+   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
+   | isUnboxedTupleType (idType bndr)
+   , [ty] <- repTypeArgs (idType bndr)
+       -- handles any pattern with a single non-void binder; in particular I/O
+       -- monad returns (# RealWorld#, a #)
+   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
 
 schemeE d s p (AnnCase scrut bndr _ alts)
    = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
@@ -636,14 +631,14 @@ schemeT d s p app
 
 
    -- Case 2: Constructor application
-   | Just con <- maybe_saturated_dcon,
-     isUnboxedTupleCon con
+   | Just con <- maybe_saturated_dcon
+   , isUnboxedTupleCon con
    = case args_r_to_l of
         [arg1,arg2] | isVAtom arg1 ->
                   unboxedTupleReturn d s p arg2
         [arg1,arg2] | isVAtom arg2 ->
                   unboxedTupleReturn d s p arg1
-        _other -> unboxedTupleException
+        _other -> multiValException
 
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
@@ -781,8 +776,8 @@ doCase  :: Word -> Sequel -> BCEnv
         -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder, don't enter the result
         -> BcM BCInstrList
 doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-  | UbxTupleRep _ <- repType (idType bndr)
-  = unboxedTupleException
+  | repTypeArgs (idType bndr) `lengthExceeds` 1
+  = multiValException
   | otherwise
   = do
      dflags <- getDynFlags
@@ -825,7 +820,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                    Nothing       -> p_alts0
 
         bndr_ty = idType bndr
-        isAlgCase = not (isUnLiftedType bndr_ty) && isNothing is_unboxed_tuple
+        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
 
         -- given an alt, return a discr and code for it.
         codeAlt (DEFAULT, _, (_,rhs))
@@ -837,8 +832,6 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | null real_bndrs = do
                 rhs_code <- schemeE d_alts s p_alts rhs
                 return (my_discr alt, rhs_code)
-           | any (\bndr -> case repType (idType bndr) of UbxTupleRep _ -> True; _ -> False) bndrs
-           = unboxedTupleException
            -- algebraic alt with some binders
            | otherwise =
              let
@@ -861,8 +854,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _)
-           | isUnboxedTupleCon dc
-           = unboxedTupleException
+           | isUnboxedTupleCon dc || isUnboxedSumCon dc
+           = multiValException
            | otherwise
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
@@ -960,7 +953,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          pargs _ [] = return []
          pargs d (a:az)
-            = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
+            = let [arg_ty] = repTypeArgs (exprType (deAnnotate' a))
 
               in case tyConAppTyCon_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
@@ -1093,10 +1086,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- this is a V (tag).
          r_sizeW   = fromIntegral (primRepSizeW dflags r_rep)
          d_after_r = d_after_Addr + fromIntegral r_sizeW
-         r_lit     = mkDummyLiteral r_rep
          push_r    = (if   returns_void
                       then nilOL
-                      else unitOL (PUSH_UBX r_lit r_sizeW))
+                      else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
 
          -- generate the marshalling code we're going to call
 
@@ -1165,7 +1157,7 @@ mkDummyLiteral pr
         FloatRep  -> MachFloat 0
         Int64Rep  -> MachInt64 0
         Word64Rep -> MachWord64 0
-        _         -> panic "mkDummyLiteral"
+        _         -> pprPanic "mkDummyLiteral" (ppr pr)
 
 
 -- Convert (eg)
@@ -1184,27 +1176,26 @@ mkDummyLiteral pr
 
 maybe_getCCallReturnRep :: Type -> Maybe PrimRep
 maybe_getCCallReturnRep fn_ty
-   = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
-         maybe_r_rep_to_go
-            = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
-         r_reps = case repType r_ty of
-                      UbxTupleRep reps -> map typePrimRep reps
-                      UnaryRep _       -> blargh
-         ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
-                || r_reps == [VoidRep] )
-              && case maybe_r_rep_to_go of
-                    Nothing    -> True
-                    Just r_rep -> r_rep /= PtrRep
-                                  -- if it was, it would be impossible
-                                  -- to create a valid return value
-                                  -- placeholder on the stack
-
-         blargh :: a -- Used at more than one type
-         blargh = pprPanic "maybe_getCCallReturn: can't handle:"
-                           (pprType fn_ty)
+   = let
+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+       r_reps = repTypeArgs r_ty
+
+       blargh :: a -- Used at more than one type
+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+                         (pprType fn_ty)
      in
-     --trace (showSDoc (ppr (a_reps, r_reps))) $
-     if ok then maybe_r_rep_to_go else blargh
+       case r_reps of
+         [] -> panic "empty repTypeArgs"
+         [ty]
+           | typePrimRep ty == PtrRep
+            -> blargh
+           | isVoidTy ty
+            -> Nothing
+           | otherwise
+            -> Just (typePrimRep ty)
+                 -- if it was, it would be impossible to create a
+                 -- valid return value placeholder on the stack
+         _  -> blargh
 
 maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
 -- Detect and extract relevant info for the tagToEnum kludge.
@@ -1216,14 +1207,14 @@ maybe_is_tagToEnum_call app
   = Nothing
   where
     extract_constr_Names ty
-           | UnaryRep rep_ty <- repType ty
-           , Just tyc <- tyConAppTyCon_maybe rep_ty,
-             isDataTyCon tyc
-             = map (getName . dataConWorkId) (tyConDataCons tyc)
-             -- NOTE: use the worker name, not the source name of
-             -- the DataCon.  See DataCon.hs for details.
+           | [rep_ty] <- repTypeArgs ty
+           , Just tyc <- tyConAppTyCon_maybe rep_ty
+           , isDataTyCon tyc
+           = map (getName . dataConWorkId) (tyConDataCons tyc)
+           -- NOTE: use the worker name, not the source name of
+           -- the DataCon.  See DataCon.hs for details.
            | otherwise
-             = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
 
 {- -----------------------------------------------------------------------------
 Note [Implementing tagToEnum#]
@@ -1316,8 +1307,14 @@ pushAtom d p e
 pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,
    = return (nilOL, 0)          -- treated just like a variable V
 
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:
+-- The scrutinee of an empty case evaluates to bottom
+pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128
+   = pushAtom d p a
+
 pushAtom d p (AnnVar v)
-   | UnaryRep rep_ty <- repType (idType v)
+   | [rep_ty] <- repTypeArgs (idType v)
    , V <- typeArgRep rep_ty
    = return (nilOL, 0)
 
@@ -1377,7 +1374,7 @@ pushAtom _ _ (AnnLit lit) = do
 
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
-              (pprCoreExpr (deAnnotate (undefined, expr)))
+              (pprCoreExpr (deAnnotate' expr))
 
 
 -- -----------------------------------------------------------------------------
@@ -1539,18 +1536,14 @@ isVoidArg V = True
 isVoidArg _ = False
 
 bcIdUnaryType :: Id -> UnaryType
-bcIdUnaryType x = case repType (idType x) of
-    UnaryRep rep_ty -> rep_ty
-    UbxTupleRep [rep_ty] -> rep_ty
-    UbxTupleRep [rep_ty1, rep_ty2]
-      | VoidRep <- typePrimRep rep_ty1 -> rep_ty2
-      | VoidRep <- typePrimRep rep_ty2 -> rep_ty1
+bcIdUnaryType x = case repTypeArgs (idType x) of
+    [rep_ty] -> rep_ty
     _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
 
 -- See bug #1257
-unboxedTupleException :: a
-unboxedTupleException = throwGhcException (ProgramError
-  ("Error: bytecode compiler can't handle unboxed tuples.\n"++
+multiValException :: a
+multiValException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
    "  Possibly due to foreign import/export decls in source.\n"++
    "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
@@ -1616,8 +1609,13 @@ atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
 atomPrimRep (AnnVar v)              = bcIdPrimRep v
 atomPrimRep (AnnLit l)              = typePrimRep (literalType l)
+
+-- Trac #12128:
+-- A case expresssion can be an atom because empty cases evaluate to bottom.
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == PtrRep) PtrRep
 atomPrimRep (AnnCoercion {})        = VoidRep
-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
+atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
 
 atomRep :: AnnExpr' Id ann -> ArgRep
 atomRep e = toArgRep (atomPrimRep e)
@@ -1646,7 +1644,8 @@ data BcM_State
         , nextlabel   :: Word16          -- for generating local labels
         , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
-        , modBreaks :: ModBreaks         -- info about breakpoints
+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
+        , breakInfo   :: IntMap CgBreakInfo
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1656,10 +1655,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: HscEnv -> UniqSupply -> Module -> ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
       -> IO (BcM_State, r)
 runBc hsc_env us this_mod modBreaks (BcM m)
-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks)
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -1688,7 +1687,6 @@ instance Applicative BcM where
 instance Monad BcM where
   (>>=) = thenBc
   (>>)  = (*>)
-  return = pure
 
 instance HasDynFlags BcM where
     getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
@@ -1700,7 +1698,7 @@ emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
 
-recordFFIBc :: RemotePtr -> BcM ()
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
 recordFFIBc a
   = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
 
@@ -1716,11 +1714,15 @@ getLabelsBc n
   = BcM $ \st -> let ctr = nextlabel st
                  in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
 
-getBreakArray :: BcM BreakArray
-getBreakArray = BcM $ \st -> return (st, modBreaks_flags (modBreaks st))
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+  return (st, modBreaks_ccs breaks)
+
 
-getCCArray :: BcM (Array BreakIndex RemotePtr {- CCostCentre -})
-getCCArray = BcM $ \st -> return (st, modBreaks_ccs (modBreaks st))
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
 
 newUnique :: BcM Unique
 newUnique = BcM $