Strings and comments only: 'to to ' fixes
[ghc.git] / compiler / ghci / ByteCodeGen.lhs
index 71a21c1..9c9526d 100644 (file)
@@ -5,6 +5,13 @@
 ByteCodeGen: Generate bytecode from Core
 
 \begin{code}
+{-# OPTIONS -fno-warn-tabs #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and
+-- detab the module (please do the detabbing in a separate patch). See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
+-- for details
+
 module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
 
 #include "HsVersions.h"
@@ -15,7 +22,9 @@ import ByteCodeAsm
 import ByteCodeLink
 import LibFFI
 
+import DynFlags
 import Outputable
+import Platform
 import Name
 import MkId
 import Id
@@ -33,16 +42,14 @@ import TyCon
 import Util
 import VarSet
 import TysPrim
-import DynFlags
 import ErrUtils
 import Unique
 import FastString
 import Panic
+import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW )
 import SMRep
-import ClosureInfo
 import Bitmap
 import OrdList
-import Constants
 
 import Data.List
 import Foreign
@@ -55,29 +62,32 @@ import UniqSupply
 import BreakArray
 import Data.Maybe
 import Module
-import IdInfo
 
+import qualified Data.ByteString        as BS
+import qualified Data.ByteString.Unsafe as BS
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified FiniteMap as Map
+import Data.Ord
 
 -- -----------------------------------------------------------------------------
 -- Generating byte code for a complete module
 
 byteCodeGen :: DynFlags
+            -> Module
             -> CoreProgram
             -> [TyCon]
             -> ModBreaks
             -> IO CompiledByteCode
-byteCodeGen dflags binds tycs modBreaks
+byteCodeGen dflags this_mod binds tycs modBreaks
    = do showPass dflags "ByteCodeGen"
 
         let flatBinds = [ (bndr, freeVars rhs)
                         | (bndr, rhs) <- flattenBinds binds]
 
         us <- mkSplitUniqSupply 'y'
-        (BcM_State _us _final_ctr mallocd _, proto_bcos)
-           <- runBc us modBreaks (mapM schemeTopBind flatBinds)
+        (BcM_State _dflags _us _this_mod _final_ctr mallocd _, proto_bcos)
+           <- runBc dflags us this_mod modBreaks (mapM schemeTopBind flatBinds)
 
         when (notNull mallocd)
              (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
@@ -93,9 +103,10 @@ byteCodeGen dflags binds tycs modBreaks
 -- Returns: (the root BCO for this expression,
 --           a list of auxilary BCOs resulting from compiling closures)
 coreExprToBCOs :: DynFlags
+               -> Module
                -> CoreExpr
                -> IO UnlinkedBCO
-coreExprToBCOs dflags expr
+coreExprToBCOs dflags this_mod expr
  = do showPass dflags "ByteCodeGen"
 
       -- create a totally bogus name for the top-level BCO; this
@@ -106,8 +117,9 @@ coreExprToBCOs dflags expr
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _us _final_ctr mallocd _ , proto_bco)
-         <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr))
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ , proto_bco)
+         <- runBc dflags us this_mod emptyModBreaks $
+              schemeTopBind (invented_id, freeVars expr)
 
       when (notNull mallocd)
            (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
@@ -122,11 +134,11 @@ coreExprToBCOs dflags expr
 
 type BCInstrList = OrdList BCInstr
 
-type Sequel = Word16 -- back off to this depth before ENTER
+type Sequel = Word -- back off to this depth before ENTER
 
 -- Maps Ids to the offset from the stack _base_ so we don't have
 -- to mess with it after each push/pop.
-type BCEnv = Map Id Word16 -- To find vars on the stack
+type BCEnv = Map Id Word -- To find vars on the stack
 
 {-
 ppBCEnv :: BCEnv -> SDoc
@@ -135,14 +147,15 @@ ppBCEnv p
      $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
      $$ text "end-env"
      where
-        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (idCgRep var)
+        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
         cmp_snd x y = compare (snd x) (snd y)
 -}
 
 -- Create a BCO and do a spot of peephole optimisation on the insns
 -- at the same time.
 mkProtoBCO
-   :: name
+   :: DynFlags
+   -> name
    -> BCInstrList
    -> Either  [AnnAlt Id VarSet] (AnnExpr Id VarSet)
    -> Int
@@ -151,7 +164,7 @@ mkProtoBCO
    -> Bool      -- True <=> is a return point, rather than a function
    -> [BcPtr]
    -> ProtoBCO name
-mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks
    = ProtoBCO {
         protoBCOName = nm,
         protoBCOInstrs = maybe_with_stack_check,
@@ -170,7 +183,7 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
         -- (hopefully rare) cases when the (overestimated) stack use
         -- exceeds iNTERP_STACK_CHECK_THRESH.
         maybe_with_stack_check
-           | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d
+           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
                 -- don't do stack checks at return points,
                 -- everything is aggregated up to the top BCO
                 -- (which must be a function).
@@ -196,11 +209,11 @@ mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_bloc
         peep []
            = []
 
-argBits :: [CgRep] -> [Bool]
-argBits [] = []
-argBits (rep : args)
-  | isFollowableArg rep = False : argBits args
-  | otherwise = take (cgRepSizeW rep) (repeat True) ++ argBits args
+argBits :: DynFlags -> [ArgRep] -> [Bool]
+argBits _      [] = []
+argBits dflags (rep : args)
+  | isFollowableArg rep  = False : argBits dflags args
+  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
 
 -- -----------------------------------------------------------------------------
 -- schemeTopBind
@@ -213,6 +226,7 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name)
 schemeTopBind (id, rhs)
   | Just data_con <- isDataConWorkId_maybe id,
     isNullaryRepDataCon data_con = do
+    dflags <- getDynFlags
         -- Special case for the worker of a nullary data con.
         -- It'll look like this:        Nil = /\a -> Nil a
         -- If we feed it into schemeR, we'll get
@@ -221,7 +235,7 @@ schemeTopBind (id, rhs)
         -- by just re-using the single top-level definition.  So
         -- for the worker itself, we must allocate it directly.
     -- ioToBc (putStrLn $ "top level BCO")
-    emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER])
+    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
                        (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
 
   | otherwise
@@ -262,60 +276,72 @@ collect :: AnnExpr Id VarSet -> ([Var], AnnExpr' Id VarSet)
 collect (_, e) = go [] e
   where
     go xs e | Just e' <- bcView e = go xs e'
-    go xs (AnnLam x (_,e))        = go (x:xs) e
-    go xs not_lambda              = (reverse xs, not_lambda)
+    go xs (AnnLam x (_,e)) 
+      | UbxTupleRep _ <- repType (idType x)
+      = unboxedTupleException
+      | 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 fvs nm original_body (args, body)
-   = let
+   = do
+     dflags <- getDynFlags
+     let
          all_args  = reverse args ++ fvs
          arity     = length all_args
          -- all_args are the args in reverse order.  We're compiling a function
          -- \fv1..fvn x1..xn -> e
          -- i.e. the fvs come first
 
-         szsw_args = map (fromIntegral . idSizeW) all_args
+         szsw_args = map (fromIntegral . idSizeW dflags) all_args
          szw_args  = sum szsw_args
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args))
 
          -- make the arg bitmap
-         bits = argBits (reverse (map idCgRep all_args))
+         bits = argBits dflags (reverse (map bcIdArgRep all_args))
          bitmap_size = genericLength bits
-         bitmap = mkBitmap bits
-     in do
+         bitmap = mkBitmap dflags bits
      body_code <- schemeER_wrk szw_args p_init body
 
-     emitBc (mkProtoBCO (getName nm) body_code (Right original_body)
+     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
                  arity bitmap_size bitmap False{-not alts-})
 
 -- introduce break instructions for ticked expressions
-schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeER_wrk :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 schemeER_wrk d p rhs
-   | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do
-        code <- schemeE d 0 p newRhs
+  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
+  = do  code <- schemeE (fromIntegral d) 0 p newRhs
         arr <- getBreakArray
-        let idOffSets = getVarOffSets d p tickInfo
-        let tickNumber = tickInfo_number tickInfo
+        this_mod <- getCurrentModule
+        let idOffSets = getVarOffSets d p fvs
         let breakInfo = BreakInfo
-                        { breakInfo_module = tickInfo_module tickInfo
-                        , breakInfo_number = tickNumber
+                        { breakInfo_module = this_mod
+                        , breakInfo_number = tick_no
                         , breakInfo_vars = idOffSets
                         , breakInfo_resty = exprType (deAnnotate' newRhs)
                         }
         let breakInstr = case arr of
                          BA arr# ->
-                             BRK_FUN arr# (fromIntegral tickNumber) breakInfo
+                             BRK_FUN arr# (fromIntegral tick_no) breakInfo
         return $ breakInstr `consOL` code
-   | otherwise = schemeE d 0 p rhs
+   | otherwise = schemeE (fromIntegral d) 0 p rhs
 
-getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)]
-getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals
+getVarOffSets :: Word -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets d p = catMaybes . map (getOffSet d p)
 
-getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16)
+getOffSet :: Word -> BCEnv -> Id -> Maybe (Id, Word16)
 getOffSet d env id
    = case lookupBCEnv_maybe id env of
         Nothing     -> Nothing
-        Just offset -> Just (id, d - offset)
+        Just offset -> Just (id, trunc16 $ d - offset)
+
+trunc16 :: Word -> Word16
+trunc16 w
+    | w > fromIntegral (maxBound :: Word16)
+    = panic "stack depth overflow"
+    | otherwise
+    = fromIntegral w
 
 fvsToEnv :: BCEnv -> VarSet -> [Id]
 -- Takes the free variables of a right-hand side, and
@@ -333,20 +359,8 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- -----------------------------------------------------------------------------
 -- schemeE
 
-data TickInfo
-   = TickInfo
-     { tickInfo_number :: Int     -- the (module) unique number of the tick
-     , tickInfo_module :: Module  -- the origin of the ticked expression
-     , tickInfo_locals :: [Id]    -- the local vars in scope at the ticked expression
-     }
-
-instance Outputable TickInfo where
-   ppr info = text "TickInfo" <+>
-              parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+>
-                      ppr (tickInfo_locals info))
-
-returnUnboxedAtom :: Word16 -> Sequel -> BCEnv 
-                 -> AnnExpr' Id VarSet -> CgRep
+returnUnboxedAtom :: Word -> Sequel -> BCEnv
+                 -> AnnExpr' Id VarSet -> ArgRep
                  -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
@@ -358,7 +372,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 :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
+schemeE :: Word -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList
 
 schemeE d s p e
    | Just e' <- bcView e
@@ -367,14 +381,12 @@ schemeE d s p e
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
 
-schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeCgRep (literalType lit))
-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg
+schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
 
 schemeE d s p e@(AnnVar v)
-   | isUnLiftedType v_type = returnUnboxedAtom d s p e (typeCgRep v_type)
-   | otherwise             = schemeT d s p e
-   where
-     v_type = idType 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))
    | (AnnVar v, args_r_to_l) <- splitApp rhs,
@@ -389,15 +401,16 @@ schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
 
 -- General case for let.  Generates correct, if inefficient, code in
 -- all situations.
-schemeE d s p (AnnLet binds (_,body))
-   = let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
+schemeE d s p (AnnLet binds (_,body)) = do
+     dflags <- getDynFlags
+     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
                                    AnnRec xs_n_rhss -> unzip xs_n_rhss
          n_binds = genericLength xs
 
          fvss  = map (fvsToEnv p' . fst) rhss
 
          -- Sizes of free vars
-         sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss
+         sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW dflags) rhs_fvs)) fvss
 
          -- the arity of each rhs
          arities = map (genericLength . fst . collect) rhss
@@ -407,7 +420,7 @@ schemeE d s p (AnnLet binds (_,body))
          -- after the closures have been allocated in the heap (but not
          -- filled in), and pointers to them parked on the stack.
          p'    = Map.insertList (zipE xs (mkStackOffsets d (genericReplicate n_binds 1))) p
-         d'    = d + n_binds
+         d'    = d + fromIntegral n_binds
          zipE  = zipEqual "schemeE"
 
          -- ToDo: don't build thunks for things with no free variables
@@ -418,7 +431,7 @@ schemeE d s p (AnnLet binds (_,body))
                      | otherwise  = MKPAP
          build_thunk dd (fv:fvs) size bco off arity = do
               (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv)
-              more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity
+              more_push_code <- build_thunk (dd + fromIntegral pushed_szw) fvs size bco off arity
               return (push_code `appOL` more_push_code)
 
          alloc_code = toOL (zipWith mkAlloc sizes arities)
@@ -440,7 +453,6 @@ schemeE d s p (AnnLet binds (_,body))
             | (fvs, x, rhs, size, arity, n) <-
                 zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
             ]
-     in do
      body_code <- schemeE d' s p' body
      thunk_codes <- sequence compile_binds
      return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
@@ -451,12 +463,11 @@ schemeE d s p (AnnLet binds (_,body))
 -- 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@(AnnCase {})
-   | Just (_tickInfo, _rhs) <- isTickedExp' exp
+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
-          --   let f = \s . case tick# of _ -> e
+          --   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
@@ -476,35 +487,64 @@ schemeE d s p exp@(AnnCase {})
          fvs  = exprFreeVars exp'
          ty   = exprType exp'
 
-schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1)
+-- ignore other kinds of tick
+schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
+
+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)
         -- Convert
-        --      case .... of x { (# VoidArg'd-thing, a #) -> ... }
+        --      case .... of x { (# V'd-thing, a #) -> ... }
         -- to
         --      case .... of a { DEFAULT -> ... }
         -- becuse 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.
-
-   = --trace "automagic mashing of case alts (# VoidArg, a #)" $
-     doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-
-   | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2)
-   = --trace "automagic mashing of case alts (# a, VoidArg #)" $
-     doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-}
-
-schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)])
-   | isUnboxedTupleCon dc
+   , 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-}
+                     | 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)] True{-unboxed tuple-}
+     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
 
 schemeE d s p (AnnCase scrut bndr _ alts)
-   = doCase d s p scrut bndr alts False{-not an unboxed tuple-}
+   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
 
 schemeE _ _ _ expr
    = pprPanic "ByteCodeGen.schemeE: unhandled case"
@@ -514,50 +554,12 @@ schemeE _ _ _ expr
    Ticked Expressions
    ------------------
 
-   A ticked expression looks like this:
-
-      case tick<n> var1 ... varN of DEFAULT -> e
-
-   (*) <n> is the number of the tick, which is unique within a module
-   (*) var1 ... varN are the local variables in scope at the tick site
-
-   If we find a ticked expression we return:
-
-      Just ((n, [var1 ... varN]), e)
-
-  otherwise we return Nothing.
-
-  The idea is that the "case tick<n> ..." is really just an annotation on
+  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
   the code. When we find such a thing, we pull out the useful information,
-  and then compile the code as if it was just the expression "e".
+  and then compile the code as if it was just the expression E.
 
 -}
 
-isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a)
-isTickedExp' (AnnCase scrut _bndr _type alts)
-   | Just tickInfo <- isTickedScrut scrut,
-     [(DEFAULT, _bndr, rhs)] <- alts
-     = Just (tickInfo, rhs)
-   where
-   isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo
-   isTickedScrut expr
-      | Var id <- f,
-        Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id
-           = Just $ TickInfo { tickInfo_number = tickNumber
-                             , tickInfo_module = modName
-                             , tickInfo_locals = idsOfArgs args
-                             }
-      | otherwise = Nothing
-      where
-      (f, args) = collectArgs $ deAnnotate expr
-      idsOfArgs :: [Expr Id] -> [Id]
-      idsOfArgs = catMaybes . map exprId
-      exprId :: Expr Id -> Maybe Id
-      exprId (Var id) = Just id
-      exprId _        = Nothing
-
-isTickedExp' _ = Nothing
-
 -- Compile code to do a tail call.  Specifically, push the fn,
 -- slide the on-stack app back down to the sequel depth,
 -- and enter.  Four cases:
@@ -569,9 +571,9 @@ isTickedExp' _ = Nothing
 --
 -- 1.  The fn denotes a ccall.  Defer to generateCCall.
 --
--- 2.  (Another nasty hack).  Spot (# a::VoidArg, b #) and treat
+-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat
 --     it simply as  b  -- since the representations are identical
---     (the VoidArg takes up zero stack space).  Also, spot
+--     (the V takes up zero stack space).  Also, spot
 --     (# b #) and treat it as  b.
 --
 -- 3.  Application of a constructor, by defn saturated.
@@ -581,7 +583,7 @@ isTickedExp' _ = Nothing
 -- 4.  Otherwise, it must be a function call.  Push the args
 --     right to left, SLIDE and ENTER.
 
-schemeT :: Word16       -- Stack depth
+schemeT :: Word         -- Stack depth
         -> Sequel       -- Sequel depth
         -> BCEnv        -- stack env
         -> AnnExpr' Id VarSet
@@ -600,7 +602,7 @@ schemeT d s p app
    = do (push, arg_words) <- pushAtom d p arg
         tagToId_sequence <- implement_tagToId constr_names
         return (push `appOL`  tagToId_sequence
-                       `appOL`  mkSLIDE 1 (d+arg_words-s)
+                       `appOL`  mkSLIDE 1 (d - s + fromIntegral arg_words)
                        `snocOL` ENTER)
 
    -- Case 1
@@ -611,9 +613,9 @@ schemeT d s p app
    | Just con <- maybe_saturated_dcon,
      isUnboxedTupleCon con
    = case args_r_to_l of
-        [arg1,arg2] | isVoidArgAtom arg1 ->
+        [arg1,arg2] | isVAtom arg1 ->
                   unboxedTupleReturn d s p arg2
-        [arg1,arg2] | isVoidArgAtom arg2 ->
+        [arg1,arg2] | isVAtom arg2 ->
                   unboxedTupleReturn d s p arg1
         _other -> unboxedTupleException
 
@@ -632,7 +634,8 @@ schemeT d s p app
       -- Detect and extract relevant info for the tagToEnum kludge.
       maybe_is_tagToEnum_call
          = let extract_constr_Names ty
-                 | Just tyc <- tyConAppTyCon_maybe (repType 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
@@ -664,7 +667,7 @@ schemeT d s p app
 -- Generate code to build a constructor application,
 -- leaving it on top of the stack
 
-mkConAppCode :: Word16 -> Sequel -> BCEnv
+mkConAppCode :: Word -> Sequel -> BCEnv
              -> DataCon                 -- The data constructor
              -> [AnnExpr' Id VarSet]    -- Args, in *reverse* order
              -> BcM BCInstrList
@@ -685,12 +688,12 @@ mkConAppCode orig_d _ p con args_r_to_l
 
       do_pushery d (arg:args)
          = do (push, arg_words) <- pushAtom d p arg
-              more_push_code <- do_pushery (d+arg_words) args
+              more_push_code <- do_pushery (d + fromIntegral arg_words) args
               return (push `appOL` more_push_code)
       do_pushery d []
          = return (unitOL (PACK con n_arg_words))
          where
-           n_arg_words = d - orig_d
+           n_arg_words = trunc16 $ d - orig_d
 
 
 -- -----------------------------------------------------------------------------
@@ -701,19 +704,15 @@ mkConAppCode orig_d _ p con args_r_to_l
 -- returned, even if it is a pointed type.  We always just return.
 
 unboxedTupleReturn
-        :: Word16 -> Sequel -> BCEnv
+        :: Word -> Sequel -> BCEnv
         -> AnnExpr' Id VarSet -> BcM BCInstrList
-unboxedTupleReturn d s p arg = do
-  (push, sz) <- pushAtom d p arg
-  return (push                      `appOL`
-          mkSLIDE sz (d-s)          `snocOL`
-          RETURN_UBX (atomRep arg))
+unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
 
 doTailCall
-        :: Word16 -> Sequel -> BCEnv
+        :: Word -> Sequel -> BCEnv
         -> Id -> [AnnExpr' Id VarSet]
         -> BcM BCInstrList
 doTailCall init_d s p fn args
@@ -724,7 +723,7 @@ doTailCall init_d s p fn args
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
         ASSERT( sz == 1 ) return ()
         return (push_fn `appOL` (
-                  mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL`
+                  mkSLIDE (trunc16 $ d - init_d + 1) (init_d - s) `appOL`
                   unitOL ENTER))
   do_pushes d args reps = do
       let (push_apply, n, rest_of_reps) = findPushSeq reps
@@ -737,32 +736,32 @@ doTailCall init_d s p fn args
   push_seq d [] = return (d, nilOL)
   push_seq d (arg:args) = do
     (push_code, sz) <- pushAtom d p arg
-    (final_d, more_push_code) <- push_seq (d+sz) args
+    (final_d, more_push_code) <- push_seq (d + fromIntegral sz) args
     return (final_d, push_code `appOL` more_push_code)
 
 -- v. similar to CgStackery.findMatch, ToDo: merge
-findPushSeq :: [CgRep] -> (BCInstr, Int, [CgRep])
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
+findPushSeq (P: P: P: P: P: P: rest)
   = (PUSH_APPLY_PPPPPP, 6, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq (P: P: P: P: P: rest)
   = (PUSH_APPLY_PPPPP, 5, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: PtrArg: rest)
+findPushSeq (P: P: P: P: rest)
   = (PUSH_APPLY_PPPP, 4, rest)
-findPushSeq (PtrArg: PtrArg: PtrArg: rest)
+findPushSeq (P: P: P: rest)
   = (PUSH_APPLY_PPP, 3, rest)
-findPushSeq (PtrArg: PtrArg: rest)
+findPushSeq (P: P: rest)
   = (PUSH_APPLY_PP, 2, rest)
-findPushSeq (PtrArg: rest)
+findPushSeq (P: rest)
   = (PUSH_APPLY_P, 1, rest)
-findPushSeq (VoidArg: rest)
+findPushSeq (V: rest)
   = (PUSH_APPLY_V, 1, rest)
-findPushSeq (NonPtrArg: rest)
+findPushSeq (N: rest)
   = (PUSH_APPLY_N, 1, rest)
-findPushSeq (FloatArg: rest)
+findPushSeq (F: rest)
   = (PUSH_APPLY_F, 1, rest)
-findPushSeq (DoubleArg: rest)
+findPushSeq (D: rest)
   = (PUSH_APPLY_D, 1, rest)
-findPushSeq (LongArg: rest)
+findPushSeq (L: rest)
   = (PUSH_APPLY_L, 1, rest)
 findPushSeq _
   = panic "ByteCodeGen.findPushSeq"
@@ -770,25 +769,32 @@ findPushSeq _
 -- -----------------------------------------------------------------------------
 -- Case expressions
 
-doCase  :: Word16 -> Sequel -> BCEnv
+doCase  :: Word -> Sequel -> BCEnv
         -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet]
-        -> Bool  -- True <=> is an unboxed tuple case, don't enter the result
+        -> 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
-  = let
+  | UbxTupleRep _ <- repType (idType bndr)
+  = unboxedTupleException
+  | otherwise
+  = do
+     dflags <- getDynFlags
+     let
         -- 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
         -- on top of the itbl.
+        ret_frame_sizeW :: Word
         ret_frame_sizeW = 2
 
         -- An unlifted value gets an extra info table pushed on top
         -- when it is returned.
+        unlifted_itbl_sizeW :: Word
         unlifted_itbl_sizeW | isAlgCase = 0
                             | otherwise = 1
 
         -- depth of stack after the return value has been pushed
-        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr)
+        d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW dflags bndr)
 
         -- depth of stack after the extra info table for an unboxed return
         -- has been pushed, if any.  This is the stack depth at the
@@ -797,10 +803,14 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 
         -- Env in which to compile the alts, not including
         -- any vars bound by the alts themselves
-        p_alts = Map.insert bndr (d_bndr - 1) p
+        d_bndr' = fromIntegral d_bndr - 1
+        p_alts0 = Map.insert bndr d_bndr' p
+        p_alts = case is_unboxed_tuple of
+                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr' p_alts0
+                   Nothing       -> p_alts0
 
         bndr_ty = idType bndr
-        isAlgCase = not (isUnLiftedType bndr_ty) && not 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))
@@ -812,12 +822,14 @@ 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
-                 (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs
-                 ptr_sizes    = map (fromIntegral . idSizeW) ptrs
-                 nptrs_sizes  = map (fromIntegral . idSizeW) nptrs
+                 (ptrs,nptrs) = partition (isFollowableArg.bcIdArgRep) real_bndrs
+                 ptr_sizes    = map (fromIntegral . idSizeW dflags) ptrs
+                 nptrs_sizes  = map (fromIntegral . idSizeW dflags) nptrs
                  bind_sizes   = ptr_sizes ++ nptrs_sizes
                  size         = sum ptr_sizes + sum nptrs_sizes
                  -- the UNPACK instruction unpacks in reverse order...
@@ -827,8 +839,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                         p_alts
              in do
              MASSERT(isAlgCase)
-             rhs_code <- schemeE (d_alts+size) s p' rhs
-             return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
+             rhs_code <- schemeE (d_alts + size) s p' rhs
+             return (my_discr alt, unitOL (UNPACK (trunc16 size)) `appOL` rhs_code)
           where
             real_bndrs = filterOut isTyVar bndrs
 
@@ -867,35 +879,36 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         -- really want a bitmap up to depth (d-s).  This affects compilation of
         -- case-of-case expressions, which is the only time we can be compiling a
         -- case expression with s /= 0.
-        bitmap_size = d-s
+        bitmap_size = trunc16 $ d-s
         bitmap_size' :: Int
         bitmap_size' = fromIntegral bitmap_size
-        bitmap = intsToReverseBitmap bitmap_size'{-size-}
-                        (sortLe (<=) (filter (< bitmap_size') rel_slots))
+        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
+                        (sort (filter (< bitmap_size') rel_slots))
           where
           binds = Map.toList p
-          rel_slots = map fromIntegral $ concat (map spread binds)
-          spread (id, offset)
-                | isFollowableArg (idCgRep id) = [ rel_offset ]
-                | otherwise = []
-                where rel_offset = d - offset - 1
+          -- NB: unboxed tuple cases bind the scrut binder to the same offset
+          -- as one of the alt binders, so we have to remove any duplicates here:
+          rel_slots = nub $ map fromIntegral $ concat (map spread binds)
+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
+                              | otherwise                      = []
+                where rel_offset = trunc16 $ d - fromIntegral offset - 1
 
-     in do
      alt_stuff <- mapM codeAlt alts
      alt_final <- mkMultiBranch maybe_ncons alt_stuff
 
      let
          alt_bco_name = getName bndr
-         alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts)
+         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
                        0{-no arity-} bitmap_size bitmap True{-is alts-}
-     -- in
 --     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) p scrut
+     scrut_code <- schemeE (d + ret_frame_sizeW)
+                           (d + ret_frame_sizeW)
+                           p scrut
      alt_bco' <- emitBc alt_bco
      let push_alts
             | isAlgCase = PUSH_ALTS alt_bco'
-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty)
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
      return (push_alts `consOL` scrut_code)
 
 
@@ -908,7 +921,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 -- (machine) code for the ccall, and create bytecodes to call that and
 -- then return in the right way.
 
-generateCCall :: Word16 -> Sequel       -- stack and sequel depths
+generateCCall :: Word -> Sequel         -- stack and sequel depths
               -> BCEnv
               -> CCallSpec              -- where to call
               -> Id                     -- of target, for type info
@@ -916,44 +929,47 @@ generateCCall :: Word16 -> Sequel       -- stack and sequel depths
               -> BcM BCInstrList
 
 generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
-   = let
+ = do
+     dflags <- getDynFlags
+
+     let
          -- useful constants
          addr_sizeW :: Word16
-         addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg)
+         addr_sizeW = fromIntegral (argRepSizeW dflags N)
 
          -- Get the args on the stack, with tags and suitably
          -- dereferenced for the CCall.  For each arg, return the
          -- depth to the first word of the bits for that arg, and the
-         -- CgRep of what was actually pushed.
+         -- ArgRep of what was actually pushed.
 
          pargs _ [] = return []
          pargs d (a:az)
-            = let arg_ty = repType (exprType (deAnnotate' a))
+            = let UnaryRep arg_ty = repType (exprType (deAnnotate' a))
 
               in case tyConAppTyCon_maybe arg_ty of
                     -- Don't push the FO; instead push the Addr# it
                     -- contains.
                     Just t
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-                       -> do rest <- pargs (d + addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-                       -> do rest <- pargs (d + addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
+                       -> do rest <- pargs (d + fromIntegral addr_sizeW) az
+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
                     _
                        -> do (code_a, sz_a) <- pushAtom d p a
-                             rest <- pargs (d+sz_a) az
+                             rest <- pargs (d + fromIntegral sz_a) az
                              return ((code_a, atomPrimRep a) : rest)
 
          -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
          -- the stack but then advance it over the headers, so as to
          -- point to the payload.
-         parg_ArrayishRep :: Word16 -> Word16 -> BCEnv -> AnnExpr' Id VarSet
+         parg_ArrayishRep :: Word16 -> Word -> BCEnv -> AnnExpr' Id VarSet
                           -> BcM BCInstrList
          parg_ArrayishRep hdrSize d p a
             = do (push_fo, _) <- pushAtom d p a
@@ -961,11 +977,10 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                  -- header and then pretend this is an Addr#.
                  return (push_fo `snocOL` SWIZZLE 0 hdrSize)
 
-     in do
      code_n_reps <- pargs d0 args_r_to_l
      let
          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
-         a_reps_sizeW = fromIntegral (sum (map primRepSizeW a_reps_pushed_r_to_l))
+         a_reps_sizeW = fromIntegral (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
 
          push_args    = concatOL pushs_arg
          d_after_args = d0 + a_reps_sizeW
@@ -1020,25 +1035,25 @@ 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
-            = case target of
+         get_target_info = do
+             case target of
                  DynamicTarget
                     -> return (False, panic "ByteCodeGen.generateCCall(dyn)")
 
-                 StaticTarget target _
+                 StaticTarget _ _ False ->
+                     panic "generateCCall: unexpected FFI value import"
+                 StaticTarget target _ True
                     -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
                           return (True, res)
                    where
                       stdcall_adj_target
-#ifdef mingw32_TARGET_OS
-                          | StdCallConv <- cconv
-                          = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
+                          | OSMinGW32 <- platformOS (targetPlatform dflags)
+                          , StdCallConv <- cconv
+                          = let size = fromIntegral a_reps_sizeW * wORD_SIZE dflags in
                             mkFastString (unpackFS target ++ '@':show size)
-#endif
                           | otherwise
                           = target
 
-     -- in
      (is_static, static_target_addr) <- get_target_info
      let
 
@@ -1053,14 +1068,14 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          (push_Addr, d_after_Addr)
             | is_static
             = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW],
-               d_after_args + addr_sizeW)
+               d_after_args + fromIntegral addr_sizeW)
             | otherwise -- is already on the stack
             = (nilOL, d_after_args)
 
          -- Push the return placeholder.  For a call returning nothing,
-         -- this is a VoidArg (tag).
-         r_sizeW   = fromIntegral (primRepSizeW r_rep)
-         d_after_r = d_after_Addr + r_sizeW
+         -- 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
@@ -1072,13 +1087,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- instruction needs to describe the chunk of stack containing
          -- the ccall args to the GC, so it needs to know how large it
          -- is.  See comment in Interpreter.c with the CCALL instruction.
-         stk_offset   = d_after_r - s
+         stk_offset   = trunc16 $ d_after_r - s
 
-     -- in
      -- 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 cconv a_reps r_rep
+     token <- ioToBc $ prepForeignCall dflags cconv a_reps r_rep
      let addr_of_marshaller = castPtrToFunPtr token
 
      recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
@@ -1087,10 +1101,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          do_call      = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
                                  (fromIntegral (fromEnum (playInterruptible safety))))
          -- slide and return
-         wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
-                        `snocOL` RETURN_UBX (primRepToCgRep r_rep)
-     --in
-         --trace (show (arg1_offW, args_offW  ,  (map cgRepSizeW a_reps) )) $
+         wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
+                        `snocOL` RETURN_UBX (toArgRep r_rep)
+         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
      return (
          push_args `appOL`
          push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
@@ -1116,7 +1129,7 @@ mkDummyLiteral pr
 --                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
 --
 -- to  Just IntRep
--- and check that an unboxed pair is returned wherein the first arg is VoidArg'd.
+-- and check that an unboxed pair is returned wherein the first arg is V'd.
 --
 -- Alternatively, for call-targets returning nothing, convert
 --
@@ -1130,13 +1143,11 @@ 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_tycon, r_reps)
-            = case splitTyConApp_maybe (repType r_ty) of
-                      (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
-                      Nothing -> blargh
+         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] )
-              && isUnboxedTupleTyCon r_tycon
               && case maybe_r_rep_to_go of
                     Nothing    -> True
                     Just r_rep -> r_rep /= PtrRep
@@ -1187,17 +1198,18 @@ implement_tagToId names
 -- to 5 and not to 4.  Stack locations are numbered from zero, so a
 -- depth 6 stack has valid words 0 .. 5.
 
-pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
+pushAtom :: Word -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16)
 
 pushAtom d p e
    | Just e' <- bcView e
    = pushAtom d p e'
 
 pushAtom _ _ (AnnCoercion {})  -- Coercions are zero-width things, 
-   = return (nilOL, 0)         -- treated just like a variable VoidArg
+   = return (nilOL, 0)         -- treated just like a variable V
 
 pushAtom d p (AnnVar v)
-   | idCgRep v == VoidArg
+   | UnaryRep rep_ty <- repType (idType v)
+   , V <- typeArgRep rep_ty
    = return (nilOL, 0)
 
    | isFCallId v
@@ -1207,8 +1219,11 @@ pushAtom d p (AnnVar v)
    = return (unitOL (PUSH_PRIMOP primop), 1)
 
    | Just d_v <- lookupBCEnv_maybe v p  -- v is a local variable
-   = let l = d - d_v + sz - 2
-     in return (toOL (genericReplicate sz (PUSH_L l)), sz)
+   = do dflags <- getDynFlags
+        let sz :: Word16
+            sz = fromIntegral (idSizeW dflags v)
+            l = trunc16 $ d - d_v + fromIntegral sz - 2
+        return (toOL (genericReplicate sz (PUSH_L l)), sz)
          -- d - d_v                 the number of words between the TOS
          --                         and the 1st slot of the object
          --
@@ -1220,51 +1235,51 @@ pushAtom d p (AnnVar v)
          -- Having found the last slot, we proceed to copy the right number of
          -- slots on to the top of the stack.
 
-    | otherwise  -- v must be a global variable
-    = ASSERT(sz == 1)
-      return (unitOL (PUSH_G (getName v)), sz)
+   | otherwise  -- v must be a global variable
+   = do dflags <- getDynFlags
+        let sz :: Word16
+            sz = fromIntegral (idSizeW dflags v)
+        MASSERT(sz == 1)
+        return (unitOL (PUSH_G (getName v)), sz)
 
-    where
-         sz :: Word16
-         sz = fromIntegral (idSizeW v)
-
-
-pushAtom _ _ (AnnLit lit)
-   = case lit of
-        MachLabel _ _ _ -> code NonPtrArg
-        MachWord _    -> code NonPtrArg
-        MachInt _     -> code NonPtrArg
-        MachWord64 _  -> code LongArg
-        MachInt64 _   -> code LongArg
-        MachFloat _   -> code FloatArg
-        MachDouble _  -> code DoubleArg
-        MachChar _    -> code NonPtrArg
-        MachNullAddr  -> code NonPtrArg
+
+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),
+                           size_host_words)
+
+     case lit of
+        MachLabel _ _ _ -> code N
+        MachWord _    -> code N
+        MachInt _     -> code N
+        MachWord64 _  -> code L
+        MachInt64 _   -> code L
+        MachFloat _   -> code F
+        MachDouble _  -> code D
+        MachChar _    -> code N
+        MachNullAddr  -> code N
         MachStr s     -> pushStr s
         -- 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
-        code rep
-           = let size_host_words = fromIntegral (cgRepSizeW rep)
-             in  return (unitOL (PUSH_UBX (Left lit) size_host_words),
-                           size_host_words)
-
         pushStr s
            = let getMallocvilleAddr
-                    = case s of
-                         FastString _ n _ fp _ ->
+                    =
                             -- 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 ptr <- ioToBc (mallocBytes (n+1))
+                                do let n = BS.length s
+                                   ptr <- ioToBc (mallocBytes (n+1))
                                    recordMallocBc ptr
                                    ioToBc (
-                                      withForeignPtr fp $ \p -> do
+                                      BS.unsafeUseAsCString s $ \p -> do
                                          memcpy ptr p (fromIntegral n)
                                          pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
                                          return ptr
@@ -1292,24 +1307,35 @@ mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt
                                 -- Nothing is always safe
               -> [(Discr, BCInstrList)]
               -> BcM BCInstrList
-mkMultiBranch maybe_ncons raw_ways
-   = let d_way     = filter (isNoDiscr.fst) raw_ways
-         notd_ways = sortLe
-                        (\w1 w2 -> leAlt (fst w1) (fst w2))
-                        (filter (not.isNoDiscr.fst) raw_ways)
+mkMultiBranch maybe_ncons raw_ways = do
+     lbl_default <- getLabelBc
 
+     let
          mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList
-         mkTree [] _range_lo _range_hi = return the_default
+         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))
+             -- shouldn't happen?
 
          mkTree [val] range_lo range_hi
-            | range_lo `eqAlt` range_hi
+            | range_lo == range_hi
             = return (snd val)
+            | null defaults -- Note [CASEFAIL]
+            = do lbl <- getLabelBc
+                 return (testEQ (fst val) lbl
+                            `consOL` (snd val
+                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))
             | otherwise
-            = do label_neq <- getLabelBc
-                 return (testEQ (fst val) label_neq
-                         `consOL` (snd val
-                         `appOL`   unitOL (LABEL label_neq)
-                         `appOL`   the_default))
+            = return (testEQ (fst val) lbl_default `consOL` snd val)
+
+            -- Note [CASEFAIL] It may be that this case has no default
+            -- branch, but the alternatives are not exhaustive - this
+            -- happens for GADT cases for example, where the types
+            -- prove that certain branches are impossible.  We could
+            -- just assume that the other cases won't occur, but if
+            -- this assumption was wrong (because of a bug in GHC)
+            -- then the result would be a segfault.  So instead we
+            -- emit an explicit test and a CASEFAIL instruction that
+            -- causes the interpreter to barf() if it is ever
+            -- executed.
 
          mkTree vals range_lo range_hi
             = let n = length vals `div` 2
@@ -1326,9 +1352,15 @@ mkMultiBranch maybe_ncons raw_ways
                       `appOL`   code_hi))
 
          the_default
-            = case d_way of [] -> unitOL CASEFAIL
-                            [(_, def)] -> def
-                            _ -> panic "mkMultiBranch/the_default"
+            = case defaults of
+                []         -> nilOL
+                [(_, def)] -> LABEL lbl_default `consOL` def
+                _          -> panic "mkMultiBranch/the_default"
+     instrs <- mkTree notd_ways init_lo init_hi
+     return (instrs `appOL` the_default)
+  where
+         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
+         notd_ways = sortBy (comparing fst) not_defaults
 
          testLT (DiscrI i) fail_label = TESTLT_I i fail_label
          testLT (DiscrW i) fail_label = TESTLT_W i fail_label
@@ -1363,22 +1395,6 @@ mkMultiBranch maybe_ncons raw_ways
                  Just n  -> (0, fromIntegral n - 1)
                  Nothing -> (minBound, maxBound)
 
-         (DiscrI i1) `eqAlt` (DiscrI i2) = i1 == i2
-         (DiscrW w1) `eqAlt` (DiscrW w2) = w1 == w2
-         (DiscrF f1) `eqAlt` (DiscrF f2) = f1 == f2
-         (DiscrD d1) `eqAlt` (DiscrD d2) = d1 == d2
-         (DiscrP i1) `eqAlt` (DiscrP i2) = i1 == i2
-         NoDiscr     `eqAlt` NoDiscr     = True
-         _           `eqAlt` _           = False
-
-         (DiscrI i1) `leAlt` (DiscrI i2) = i1 <= i2
-         (DiscrW w1) `leAlt` (DiscrW w2) = w1 <= w2
-         (DiscrF f1) `leAlt` (DiscrF f2) = f1 <= f2
-         (DiscrD d1) `leAlt` (DiscrD d2) = d1 <= d2
-         (DiscrP i1) `leAlt` (DiscrP i2) = i1 <= i2
-         NoDiscr     `leAlt` NoDiscr     = True
-         _           `leAlt` _           = False
-
          isNoDiscr NoDiscr = True
          isNoDiscr _       = False
 
@@ -1395,8 +1411,6 @@ mkMultiBranch maybe_ncons raw_ways
          maxF =  1.0e37
          minD = -1.0e308
          maxD =  1.0e308
-     in
-         mkTree notd_ways init_lo init_hi
 
 
 -- -----------------------------------------------------------------------------
@@ -1410,6 +1424,7 @@ data Discr
    | DiscrD Double
    | DiscrP Word16
    | NoDiscr
+    deriving (Eq, Ord)
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i
@@ -1420,24 +1435,58 @@ instance Outputable Discr where
    ppr NoDiscr    = text "DEF"
 
 
-lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word16
+lookupBCEnv_maybe :: Id -> BCEnv -> Maybe Word
 lookupBCEnv_maybe = Map.lookup
 
-idSizeW :: Id -> Int
-idSizeW id = cgRepSizeW (typeCgRep (idType id))
+idSizeW :: DynFlags -> Id -> Int
+idSizeW dflags = argRepSizeW dflags . bcIdArgRep
+
+bcIdArgRep :: Id -> ArgRep
+bcIdArgRep = toArgRep . bcIdPrimRep
+
+bcIdPrimRep :: Id -> PrimRep
+bcIdPrimRep = typePrimRep . bcIdUnaryType
+
+isFollowableArg :: ArgRep -> Bool
+isFollowableArg P = True
+isFollowableArg _ = False
+
+isVoidArg :: ArgRep -> Bool
+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
+    _ -> pprPanic "bcIdUnaryType" (ppr x $$ ppr (idType x))
 
 -- See bug #1257
 unboxedTupleException :: a
 unboxedTupleException
-   = ghcError
+   = 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."))
 
 
-mkSLIDE :: Word16 -> Word16 -> OrdList BCInstr
-mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
+mkSLIDE :: Word16 -> Word -> OrdList BCInstr
+mkSLIDE n d
+    -- if the amount to slide doesn't fit in a word,
+    -- generate multiple slide instructions
+    | d > fromIntegral limit
+    = SLIDE n limit `consOL` mkSLIDE n (d - fromIntegral limit)
+    | d == 0
+    = nilOL
+    | otherwise
+    = if d == 0 then nilOL else unitOL (SLIDE n $ fromIntegral d)
+    where
+        limit :: Word16
+        limit = maxBound
 
 splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])
         -- The arguments are returned in *right-to-left* order
@@ -1452,53 +1501,59 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 --  a) type abstractions
 --  b) type applications
 --  c) casts
---  d) notes
+--  d) ticks (but not breakpoints)
 -- Type lambdas *can* occur in random expressions,
 -- whereas value lambdas cannot; that is why they are nuked here
-bcView (AnnNote _ (_,e))            = Just e
-bcView (AnnCast (_,e) _)            = Just e
+bcView (AnnCast (_,e) _)             = Just e
 bcView (AnnLam v (_,e)) | isTyVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView (AnnTick Breakpoint{} _)      = Nothing
+bcView (AnnTick _other_tick (_,e))   = Just e
 bcView _                             = Nothing
 
-isVoidArgAtom :: AnnExpr' Var ann -> Bool
-isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
-isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
-isVoidArgAtom (AnnCoercion {})        = True
-isVoidArgAtom _                      = False
+isVAtom :: AnnExpr' Var ann -> Bool
+isVAtom e | Just e' <- bcView e = isVAtom e'
+isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)
+isVAtom (AnnCoercion {})        = True
+isVAtom _                    = False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
-atomPrimRep (AnnVar v)             = typePrimRep (idType v)
+atomPrimRep (AnnVar v)             = bcIdPrimRep v
 atomPrimRep (AnnLit l)             = typePrimRep (literalType l)
 atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
-atomRep :: AnnExpr' Id ann -> CgRep
-atomRep e = primRepToCgRep (atomPrimRep e)
+atomRep :: AnnExpr' Id ann -> ArgRep
+atomRep e = toArgRep (atomPrimRep e)
 
 isPtrAtom :: AnnExpr' Id ann -> Bool
-isPtrAtom e = atomRep e == PtrArg
+isPtrAtom e = isFollowableArg (atomRep e)
 
 -- Let szsw be the sizes in words of some items pushed onto the stack,
 -- which has initial depth d'.  Return the values which the stack environment
 -- should map these items to.
-mkStackOffsets :: Word16 -> [Word16] -> [Word16]
+mkStackOffsets :: Word -> [Word] -> [Word]
 mkStackOffsets original_depth szsw
    = map (subtract 1) (tail (scanl (+) original_depth szsw))
 
+typeArgRep :: Type -> ArgRep
+typeArgRep = toArgRep . typePrimRep
+
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad
 
 type BcPtr = Either ItblPtr (Ptr ())
 
 data BcM_State
-   = BcM_State {
-        uniqSupply :: UniqSupply,       -- for generating fresh variable names
-        nextlabel :: Word16,            -- for generating local labels
-        malloced  :: [BcPtr],           -- thunks malloced for current BCO
-                                        -- Should be free()d when it is GCd
-        breakArray :: BreakArray        -- array of breakpoint flags
+   = 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
+                                         -- Should be free()d when it is GCd
+        , breakArray :: BreakArray       -- array of breakpoint flags
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1508,9 +1563,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us modBreaks (BcM m)
-   = m (BcM_State us 0 [] breakArray)
+runBc :: DynFlags -> UniqSupply -> Module -> 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
 
@@ -1535,6 +1591,9 @@ instance Monad BcM where
   (>>)  = thenBc_
   return = returnBc
 
+instance HasDynFlags BcM where
+    getDynFlags = BcM $ \st -> return (st, bcm_dflags st)
+
 emitBc :: ([BcPtr] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
 emitBc bco
   = BcM $ \st -> return (st{malloced=[]}, bco (malloced st))
@@ -1568,6 +1627,9 @@ newUnique = BcM $
              (uniq, us) -> let newState = st { uniqSupply = us }
                            in  return (newState, uniq)
 
+getCurrentModule :: BcM Module
+getCurrentModule = BcM $ \st -> return (st, thisModule st)
+
 newId :: Type -> BcM Id
 newId ty = do
     uniq <- newUnique