Implement unboxed sum primitive type
[ghc.git] / compiler / ghci / ByteCodeGen.hs
index 347b398..9c7d25a 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -9,11 +9,13 @@ module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 #include "HsVersions.h"
 
 import ByteCodeInstr
-import ByteCodeItbls
 import ByteCodeAsm
-import ByteCodeLink
-import LibFFI
+import ByteCodeTypes
 
+import GHCi
+import GHCi.FFI
+import GHCi.RemoteTypes
+import BasicTypes
 import DynFlags
 import Outputable
 import Platform
@@ -29,6 +31,8 @@ import Literal
 import PrimOp
 import CoreFVs
 import Type
+import RepType
+import Kind            ( isLiftedTypeKind )
 import DataCon
 import TyCon
 import Util
@@ -42,68 +46,71 @@ import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
 import SMRep
 import Bitmap
 import OrdList
+import Maybes
 
 import Data.List
 import Foreign
-import Foreign.C
-
-#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 qualified Data.ByteString        as BS
-import qualified Data.ByteString.Unsafe as BS
+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
 
-byteCodeGen :: DynFlags
+byteCodeGen :: HscEnv
             -> Module
             -> CoreProgram
             -> [TyCon]
-            -> ModBreaks
+            -> Maybe ModBreaks
             -> IO CompiledByteCode
-byteCodeGen dflags this_mod binds tycs modBreaks
-   = do showPass dflags "ByteCodeGen"
-
-        let flatBinds = [ (bndr, freeVars rhs)
+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 _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
-           <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
+        (BcM_State{..}, proto_bcos) <-
+           runBc hsc_env us this_mod mb_modBreaks $
+             mapM schemeTopBind flatBinds
 
-        when (notNull mallocd)
+        when (notNull ffis)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
 
         dumpIfSet_dyn dflags Opt_D_dump_BCOs
            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
-        assembleBCOs dflags proto_bcos tycs
+        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)
-coreExprToBCOs :: DynFlags
+-- Returns: the root BCO for this expression
+coreExprToBCOs :: HscEnv
                -> Module
                -> CoreExpr
                -> IO UnlinkedBCO
-coreExprToBCOs dflags this_mod expr
- = do showPass dflags "ByteCodeGen"
-
+coreExprToBCOs hsc_env this_mod expr
+ = 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")
@@ -112,17 +119,42 @@ coreExprToBCOs dflags 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 dflags us this_mod emptyModBreaks $
-              schemeTopBind (invented_id, freeVars expr)
+      (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)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
 
       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.
+simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
+simpleFreeVars = go . freeVars
+  where
+    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
+    go (ann, e) = (freeVarsOfAnn ann, go' e)
+
+    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
+    go' (AnnVar id)                  = AnnVar id
+    go' (AnnLit lit)                 = AnnLit lit
+    go' (AnnLam bndr body)           = AnnLam bndr (go body)
+    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)
+    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
+    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)
+    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)
+    go' (AnnTick tick body)          = AnnTick tick (go body)
+    go' (AnnType ty)                 = AnnType ty
+    go' (AnnCoercion co)             = AnnCoercion co
+
+    go_alt (con, args, expr) = (con, args, go expr)
+
+    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
+    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)
 
 -- -----------------------------------------------------------------------------
 -- Compilation schema for the bytecode generator
@@ -152,14 +184,14 @@ mkProtoBCO
    :: DynFlags
    -> name
    -> BCInstrList
-   -> Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet)
+   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
    -> Int
    -> Word16
    -> [StgWord]
    -> Bool      -- True <=> is a return point, rather than a function
-   -> [BcPtr]
+   -> [FFIInfo]
    -> ProtoBCO name
-mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
    = ProtoBCO {
         protoBCOName = nm,
         protoBCOInstrs = maybe_with_stack_check,
@@ -167,7 +199,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallo
         protoBCOBitmapSize = bitmap_size,
         protoBCOArity = arity,
         protoBCOExpr = origin,
-        protoBCOPtrs = mallocd_blocks
+        protoBCOFFIs = ffis
       }
      where
         -- Overestimate the stack usage (in words) of this BCO,
@@ -215,7 +247,7 @@ argBits dflags (rep : args)
 
 -- Compile code for the right-hand side of a top-level binding
 
-schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
+schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
 
 
 schemeTopBind (id, rhs)
@@ -252,13 +284,13 @@ schemeTopBind (id, rhs)
 schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
                                 -- will appear in the thunk.  Empty for
                                 -- top-level things, which have no free vars.
-        -> (Id, AnnExpr Id VarSet)
+        -> (Id, AnnExpr Id DVarSet)
         -> BcM (ProtoBCO Name)
 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
@@ -267,18 +299,18 @@ schemeR fvs (nm, rhs)
 -}
    = schemeR_wrk fvs nm rhs (collect rhs)
 
-collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
+collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
 collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
     go xs (AnnLam x (_,e))
-      | UbxTupleRep _ <- repType (idType x)
-      = unboxedTupleException
+      | repTypeArgs (idType x) `lengthExceeds` 1
+      = multiValException
       | otherwise
       = go (x:xs) e
     go xs not_lambda = (reverse xs, not_lambda)
 
-schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name)
+schemeR_wrk :: [Id] -> Id -> AnnExpr Id DVarSet -> ([Var], AnnExpr' Var DVarSet) -> BcM (ProtoBCO Name)
 schemeR_wrk fvs nm original_body (args, body)
    = do
      dflags <- getDynFlags
@@ -303,22 +335,22 @@ schemeR_wrk fvs nm original_body (args, body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
-schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+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
-        arr <- getBreakArray
-        this_mod <- getCurrentModule
+        cc_arr <- getCCArray
+        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)
                         }
-        let breakInstr = case arr of
-                         BA arr# ->
-                             BRK_FUN arr# (fromIntegral tick_no) breakInfo
+        newBreakInfo tick_no breakInfo
+        dflags <- getDynFlags
+        let cc | interpreterProfiled dflags = cc_arr ! tick_no
+               | otherwise = toRemotePtr nullPtr
+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
         return $ breakInstr `consOL` code
    | otherwise = schemeE (fromIntegral d) 0 p rhs
 
@@ -338,7 +370,7 @@ trunc16 w
     | otherwise
     = fromIntegral w
 
-fvsToEnv :: BCEnv -> VarSet -> [Id]
+fvsToEnv :: BCEnv -> DVarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
 -- delivers an ordered list of the local variables that will
 -- be captured in the thunk for the RHS
@@ -347,7 +379,7 @@ fvsToEnv :: BCEnv -> VarSet -> [Id]
 --
 -- The code that constructs the thunk, and the code that executes
 -- it, have to agree about this layout
-fvsToEnv p fvs = [v | v <- varSetElems fvs,
+fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
                       isId v,           -- Could be a type variable
                       v `Map.member` p]
 
@@ -355,7 +387,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- schemeE
 
 returnUnboxedAtom :: Word -> Sequel -> BCEnv
-                 -> AnnExpr' Id VarSet -> ArgRep
+                 -> AnnExpr' Id DVarSet -> ArgRep
                  -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
@@ -367,7 +399,7 @@ returnUnboxedAtom d s p e e_rep
 
 -- Compile code to apply the given expression to the remaining args
 -- on the stack, returning a HNF.
-schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
 
 schemeE d s p e
    | Just e' <- bcView e
@@ -380,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))
@@ -452,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 (emptyVarSet, exp)))
-                              (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id)
-                                                    (emptyVarSet, 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)) (emptyVarSet, AnnVar id)
+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
+                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
+                                                    (emptyDVarSet, AnnVar realWorldPrimId)))
           schemeE d s p letExp
-   where exp' = deAnnotate' exp
-         fvs  = exprFreeVars 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
@@ -489,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-}
@@ -581,7 +608,7 @@ schemeE _ _ _ expr
 schemeT :: Word         -- Stack depth
         -> Sequel       -- Sequel depth
         -> BCEnv        -- stack env
-        -> AnnExpr' Id VarSet
+        -> AnnExpr' Id DVarSet
         -> BcM BCInstrList
 
 schemeT d s p app
@@ -598,17 +625,20 @@ schemeT d s p app
 
    -- Case 1
    | Just (CCall ccall_spec) <- isFCallId_maybe fn
-   = generateCCall d s p ccall_spec fn args_r_to_l
+   = if isSupportedCConv ccall_spec
+      then generateCCall d s p ccall_spec fn args_r_to_l
+      else unsupportedCConvException
+
 
    -- 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
@@ -641,7 +671,7 @@ schemeT d s p app
 
 mkConAppCode :: Word -> Sequel -> BCEnv
              -> DataCon                 -- The data constructor
-             -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
+             -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
              -> BcM BCInstrList
 
 mkConAppCode _ _ _ con []       -- Nullary constructor
@@ -677,7 +707,7 @@ mkConAppCode orig_d _ p con args_r_to_l
 
 unboxedTupleReturn
         :: Word -> Sequel -> BCEnv
-        -> AnnExpr' Id VarSet -> BcM BCInstrList
+        -> AnnExpr' Id DVarSet -> BcM BCInstrList
 unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 -- -----------------------------------------------------------------------------
@@ -685,7 +715,7 @@ unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 doTailCall
         :: Word -> Sequel -> BCEnv
-        -> Id -> [AnnExpr' Id VarSet]
+        -> Id -> [AnnExpr' Id DVarSet]
         -> BcM BCInstrList
 doTailCall init_d s p fn args
   = do_pushes init_d args (map atomRep args)
@@ -742,16 +772,20 @@ findPushSeq _
 -- Case expressions
 
 doCase  :: Word -> Sequel -> BCEnv
-        -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
+        -> AnnExpr Id DVarSet -> Id -> [AnnAlt Id DVarSet]
         -> 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
      let
+        profiling
+          | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+          | otherwise = rtsIsProfiled
+
         -- Top of stack is the return itbl, as usual.
         -- underneath it is the pointer to the alt_code BCO.
         -- When an alt is entered, it assumes the returned value is
@@ -759,6 +793,10 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         ret_frame_sizeW :: Word
         ret_frame_sizeW = 2
 
+        -- The extra frame we push to save/restor the CCCS when profiling
+        save_ccs_sizeW | profiling = 2
+                       | otherwise = 0
+
         -- An unlifted value gets an extra info table pushed on top
         -- when it is returned.
         unlifted_itbl_sizeW :: Word
@@ -782,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))
@@ -794,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
@@ -818,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, _, _)
@@ -874,8 +910,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                        0{-no arity-} bitmap_size bitmap True{-is alts-}
 --     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
 --            "\n      bitmap = " ++ show bitmap) $ do
-     scrut_code <- schemeE (d + ret_frame_sizeW)
-                           (d + ret_frame_sizeW)
+
+     scrut_code <- schemeE (d + ret_frame_sizeW + save_ccs_sizeW)
+                           (d + ret_frame_sizeW + save_ccs_sizeW)
                            p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
@@ -897,7 +934,7 @@ generateCCall :: Word -> Sequel         -- stack and sequel depths
               -> BCEnv
               -> CCallSpec              -- where to call
               -> Id                     -- of target, for type info
-              -> [AnnExpr' Id VarSet]   -- args (atoms)
+              -> [AnnExpr' Id DVarSet]   -- args (atoms)
               -> BcM BCInstrList
 
 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
@@ -916,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
@@ -946,7 +983,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
          -- point to the payload.
-         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
+         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id DVarSet
                           -> BcM BCInstrList
          parg_ArrayishRep hdrSize d p a
             = do (push_fo, _) <- pushAtom d p a
@@ -1012,27 +1049,23 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
             void marshall_code ( StgWord* ptr_to_top_of_stack )
          -}
          -- resolve static address
-         get_target_info = do
+         maybe_static_target =
              case target of
-                 DynamicTarget
-                    -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
-
+                 DynamicTarget -> Nothing
                  StaticTarget _ _ _ False ->
-                     panic "generateCCall: unexpected FFI value import"
-                 StaticTarget _ target _ True
-                    -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
-                          return (True, res)
+                   panic "generateCCall: unexpected FFI value import"
+                 StaticTarget _ target _ True ->
+                   Just (MachLabel target mb_size IsFunction)
                    where
-                      stdcall_adj_target
+                      mb_size
                           | OSMinGW32 <- platformOS (targetPlatform dflags)
                           , StdCallConv <- cconv
-                          = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
-                            mkFastString (unpackFS target ++ '@':show size)
+                          = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
                           | otherwise
-                          = target
+                          = Nothing
 
-     (is_static, static_target_addr) <- get_target_info
      let
+         is_static = isJust maybe_static_target
 
          -- Get the arg reps, zapping the leading Addr# in the dynamic case
          a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
@@ -1043,8 +1076,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          -- push the Addr#
          (push_Addr, d_after_Addr)
-            | is_static
-            = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
+            | Just machlabel <- maybe_static_target
+            = (toOL [PUSH_UBX machlabel addr_sizeW],
                d_after_args + fromIntegral addr_sizeW)
             | otherwise -- is already on the stack
             = (nilOL, d_after_args)
@@ -1053,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 (Left r_lit) r_sizeW))
+                      else unitOL (PUSH_UBX (mkDummyLiteral r_rep) r_sizeW))
 
          -- generate the marshalling code we're going to call
 
@@ -1066,16 +1098,25 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- is.  See comment in Interpreter.c with the CCALL instruction.
          stk_offset   = trunc16 $ d_after_r - s
 
+         conv = case cconv of
+           CCallConv -> FFICCall
+           StdCallConv -> FFIStdCall
+           _ -> panic "ByteCodeGen: unexpected calling convention"
+
      -- the only difference in libffi mode is that we prepare a cif
      -- describing the call type by calling libffi, and we attach the
      -- address of this to the CCALL instruction.
-     token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
-     let addr_of_marshaller = castPtrToFunPtr token
 
-     recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
+
+     let ffires = primRepToFFIType dflags r_rep
+         ffiargs = map (primRepToFFIType dflags) a_reps
+     hsc_env <- getHscEnv
+     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+     recordFFIBc token
+
      let
          -- do the call
-         do_call      = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
+         do_call      = unitOL (CCALL stk_offset token
                                  (fromIntegral (fromEnum (playInterruptible safety))))
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
@@ -1086,6 +1127,24 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
          )
 
+primRepToFFIType :: DynFlags -> PrimRep -> FFIType
+primRepToFFIType dflags r
+  = case r of
+     VoidRep     -> FFIVoid
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> FFISInt64
+     Word64Rep   -> FFIUInt64
+     AddrRep     -> FFIPointer
+     FloatRep    -> FFIFloat
+     DoubleRep   -> FFIDouble
+     _           -> panic "primRepToFFIType"
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)
+       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)
+       | otherwise              = panic "primTyDescChar"
+
 -- Make a dummy literal, to be used as a placeholder for FFI return
 -- values on the stack.
 mkDummyLiteral :: PrimRep -> Literal
@@ -1098,7 +1157,7 @@ mkDummyLiteral pr
         FloatRep  -> MachFloat 0
         Int64Rep  -> MachInt64 0
         Word64Rep -> MachWord64 0
-        _         -> panic "mkDummyLiteral"
+        _         -> pprPanic "mkDummyLiteral" (ppr pr)
 
 
 -- Convert (eg)
@@ -1117,29 +1176,28 @@ 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 VarSet -> Maybe (AnnExpr' Id VarSet, [Name])
+maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
 -- Detect and extract relevant info for the tagToEnum kludge.
 maybe_is_tagToEnum_call app
   | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
@@ -1149,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#]
@@ -1197,7 +1255,7 @@ a 1-word null. See Trac #8383.
 
 
 implement_tagToId :: Word -> Sequel -> BCEnv
-                  -> AnnExpr' Id VarSet -> [Name] -> BcM BCInstrList
+                  -> AnnExpr' Id DVarSet -> [Name] -> BcM BCInstrList
 -- See Note [Implementing tagToEnum#]
 implement_tagToId d s p arg names
   = ASSERT( notNull names )
@@ -1210,7 +1268,7 @@ implement_tagToId d s p arg names
            steps = map (mkStep label_exit) infos
 
        return (push_arg
-               `appOL` unitOL (PUSH_UBX (Left MachNullAddr) 1)
+               `appOL` unitOL (PUSH_UBX MachNullAddr 1)
                    -- Push bogus word (see Note [Implementing tagToEnum#])
                `appOL` concatOL steps
                `appOL` toOL [ LABEL label_fail, CASEFAIL,
@@ -1240,7 +1298,7 @@ implement_tagToId d s p arg names
 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
 -- depth 6 stack has valid words 0 .. 5.
 
-pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
+pushAtom :: Word -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, Word16)
 
 pushAtom d p e
    | Just e' <- bcView e
@@ -1249,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)
 
@@ -1289,7 +1353,7 @@ pushAtom _ _ (AnnLit lit) = do
      dflags <- getDynFlags
      let code rep
              = let size_host_words = fromIntegral (argRepSizeW dflags rep)
-               in  return (unitOL (PUSH_UBX (Left lit) size_host_words),
+               in  return (unitOL (PUSH_UBX lit size_host_words),
                            size_host_words)
 
      case lit of
@@ -1302,41 +1366,15 @@ pushAtom _ _ (AnnLit lit) = do
         MachDouble _  -> code D
         MachChar _    -> code N
         MachNullAddr  -> code N
-        MachStr s     -> pushStr s
+        MachStr _     -> code N
         -- No LitInteger's should be left by the time this is called.
         -- CorePrep should have converted them all to a real core
         -- representation.
         LitInteger {} -> panic "pushAtom: LitInteger"
-     where
-        pushStr s
-           = let getMallocvilleAddr
-                    =
-                            -- we could grab the Ptr from the ForeignPtr,
-                            -- but then we have no way to control its lifetime.
-                            -- In reality it'll probably stay alive long enoungh
-                            -- by virtue of the global FastString table, but
-                            -- to be on the safe side we copy the string into
-                            -- a malloc'd area of memory.
-                                do let n = BS.length s
-                                   ptr <- ioToBc (mallocBytes (n+1))
-                                   recordMallocBc ptr
-                                   ioToBc (
-                                      BS.unsafeUseAsCString s $ \p -> do
-                                         memcpy ptr p (fromIntegral n)
-                                         pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
-                                         return ptr
-                                      )
-             in do
-                addr <- getMallocvilleAddr
-                -- Get the addr on the stack, untaggedly
-                return (unitOL (PUSH_UBX (Right addr) 1), 1)
 
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
-              (pprCoreExpr (deAnnotate (undefined, expr)))
-
-foreign import ccall unsafe "memcpy"
- memcpy :: Ptr a -> Ptr b -> CSize -> IO ()
+              (pprCoreExpr (deAnnotate' expr))
 
 
 -- -----------------------------------------------------------------------------
@@ -1498,23 +1536,31 @@ 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"++
-            "  Possibly due to foreign import/export decls in source.\n"++
-            "  Workaround: use -fobject-code, or compile this module to .o separately."))
-
+multiValException :: a
+multiValException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++
+   "  Possibly due to foreign import/export decls in source.\n"++
+   "  Workaround: use -fobject-code, or compile this module to .o separately."))
+
+-- | Indicate if the calling convention is supported
+isSupportedCConv :: CCallSpec -> Bool
+isSupportedCConv (CCallSpec _ cconv _) = case cconv of
+   CCallConv            -> True     -- we explicitly pattern match on every
+   StdCallConv          -> True     -- convention to ensure that a warning
+   PrimCallConv         -> False    -- is triggered when a new one is added
+   JavaScriptCallConv   -> False
+   CApiConv             -> False
+
+-- See bug #10462
+unsupportedCConvException :: a
+unsupportedCConvException = throwGhcException (ProgramError
+  ("Error: bytecode compiler can't handle some foreign calling conventions\n"++
+   "  Workaround: use -fobject-code, or compile this module to .o separately."))
 
 mkSLIDE :: Word16 -> Word -> OrdList BCInstr
 mkSLIDE n d
@@ -1563,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)
@@ -1585,17 +1636,16 @@ typeArgRep = toArgRep . typePrimRep
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad
 
-type BcPtr = Either ItblPtr (Ptr ())
-
 data BcM_State
    = BcM_State
-        { bcm_dflags :: DynFlags
-        , uniqSupply :: UniqSupply       -- for generating fresh variable names
-        , thisModule :: Module           -- current module (for breakpoints)
-        , nextlabel :: Word16            -- for generating local labels
-        , malloced  :: [BcPtr]           -- thunks malloced for current BCO
+        { bcm_hsc_env :: HscEnv
+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names
+        , thisModule  :: Module          -- current module (for breakpoints)
+        , nextlabel   :: Word16          -- for generating local labels
+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
                                          -- Should be free()d when it is GCd
-        , breakArray :: BreakArray       -- array of breakpoint flags
+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
+        , breakInfo   :: IntMap CgBreakInfo
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1605,12 +1655,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: DynFlags -> UniqSupply -> Module -> ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
       -> IO (BcM_State, r)
-runBc dflags us this_mod modBreaks (BcM m)
-   = m (BcM_State dflags us this_mod 0 [] breakArray)
-   where
-   breakArray = modBreaks_flags modBreaks
+runBc hsc_env us this_mod modBreaks (BcM m)
+   = 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
@@ -1632,28 +1680,27 @@ instance Functor BcM where
     fmap = liftM
 
 instance Applicative BcM where
-    pure = return
+    pure = returnBc
     (<*>) = ap
+    (*>) = thenBc_
 
 instance Monad BcM where
   (>>=) = thenBc
-  (>>)  = thenBc_
-  return = returnBc
+  (>>)  = (*>)
 
 instance HasDynFlags BcM where
-    getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
 
-emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
-emitBc bco
-  = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
 
-recordMallocBc :: Ptr a -> BcM ()
-recordMallocBc a
-  = BcM $ \st -> return (st{malloced = Right (castPtr a) : malloced st}, ())
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
 
-recordItblMallocBc :: ItblPtr -> BcM ()
-recordItblMallocBc a
-  = BcM $ \st -> return (st{malloced = Left a : malloced st}, ())
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
+recordFFIBc a
+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
 
 getLabelBc :: BcM Word16
 getLabelBc
@@ -1667,8 +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, breakArray st)
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+  return (st, modBreaks_ccs breaks)
+
+
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
 
 newUnique :: BcM Unique
 newUnique = BcM $