Strings and comments only: 'to to ' fixes
[ghc.git] / compiler / ghci / ByteCodeGen.lhs
index 851ca38..9c9526d 100644 (file)
@@ -22,7 +22,9 @@ import ByteCodeAsm
 import ByteCodeLink
 import LibFFI
 
+import DynFlags
 import Outputable
+import Platform
 import Name
 import MkId
 import Id
@@ -40,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
@@ -63,9 +63,12 @@ import BreakArray
 import Data.Maybe
 import Module
 
+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
@@ -83,8 +86,8 @@ byteCodeGen dflags this_mod binds tycs modBreaks
                         | (bndr, rhs) <- flattenBinds binds]
 
         us <- mkSplitUniqSupply 'y'
-        (BcM_State _us _this_mod _final_ctr mallocd _, proto_bcos)
-           <- runBc us this_mod 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?")
@@ -114,8 +117,8 @@ 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 _us _this_mod _final_ctr mallocd _ , proto_bco)
-         <- runBc us this_mod emptyModBreaks $
+      (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)
@@ -144,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
@@ -160,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,
@@ -179,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).
@@ -205,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
@@ -222,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
@@ -230,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
@@ -280,25 +285,26 @@ collect (_, e) = go [] e
 
 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
@@ -354,7 +360,7 @@ fvsToEnv p fvs = [v | v <- varSetElems fvs,
 -- schemeE
 
 returnUnboxedAtom :: Word -> Sequel -> BCEnv
-                 -> AnnExpr' Id VarSet -> CgRep
+                 -> AnnExpr' Id VarSet -> ArgRep
                  -> BcM BCInstrList
 -- Returning an unlifted value.
 -- Heave it on the stack, SLIDE, and RETURN.
@@ -375,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,
@@ -397,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
@@ -448,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)
@@ -489,35 +493,58 @@ 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 _ _ [(DataAlt dc, [bind1, bind2], rhs)])
-   | isUnboxedTupleCon dc, UnaryRep rep_ty <- repType (idType bind1), VoidRep <- typePrimRep rep_ty
+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, UnaryRep rep_ty <- repType (idType bind2), VoidRep <- typePrimRep rep_ty
-   = --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)])
+   , 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"
@@ -544,9 +571,9 @@ schemeE _ _ _ expr
 --
 -- 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.
@@ -586,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
 
@@ -679,11 +706,7 @@ mkConAppCode orig_d _ p con args_r_to_l
 unboxedTupleReturn
         :: 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
@@ -717,28 +740,28 @@ doTailCall init_d s p fn 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"
@@ -748,13 +771,15 @@ findPushSeq _
 
 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
   | UbxTupleRep _ <- repType (idType bndr)
   = unboxedTupleException
   | otherwise
-  = let
+  = 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
@@ -769,7 +794,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                             | 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
@@ -778,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 (fromIntegral 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))
@@ -798,9 +827,9 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            -- 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...
@@ -853,25 +882,24 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
         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 = []
+          -- 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)
@@ -880,7 +908,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
      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)
 
 
@@ -901,15 +929,18 @@ generateCCall :: Word -> 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)
@@ -921,12 +952,12 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                     Just t
                      | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
                        -> do rest <- pargs (d + fromIntegral addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a
+                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                      | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
                        -> do rest <- pargs (d + fromIntegral addr_sizeW) az
-                             code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a
+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
                              return ((code,AddrRep):rest)
 
                     -- Default case: push taggedly, but otherwise intact.
@@ -946,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
@@ -1005,8 +1035,8 @@ 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)")
 
@@ -1017,15 +1047,13 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                           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
 
@@ -1045,8 +1073,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
             = (nilOL, d_after_args)
 
          -- Push the return placeholder.  For a call returning nothing,
-         -- this is a VoidArg (tag).
-         r_sizeW   = fromIntegral (primRepSizeW r_rep)
+         -- 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
@@ -1061,11 +1089,10 @@ 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
 
-     -- 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))
@@ -1075,9 +1102,8 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
                                  (fromIntegral (fromEnum (playInterruptible safety))))
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - fromIntegral r_sizeW - s)
-                        `snocOL` RETURN_UBX (primRepToCgRep r_rep)
-     --in
-         --trace (show (arg1_offW, args_offW  ,  (map cgRepSizeW a_reps) )) $
+                        `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
@@ -1103,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
 --
@@ -1179,10 +1205,11 @@ pushAtom d p 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
@@ -1192,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 = trunc16 $ d - d_v + fromIntegral 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
          --
@@ -1205,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
@@ -1286,7 +1316,7 @@ mkMultiBranch maybe_ncons raw_ways = do
              -- 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
@@ -1326,14 +1356,11 @@ mkMultiBranch maybe_ncons raw_ways = do
                 []         -> nilOL
                 [(_, def)] -> LABEL lbl_default `consOL` def
                 _          -> panic "mkMultiBranch/the_default"
-     -- in
      instrs <- mkTree notd_ways init_lo init_hi
      return (instrs `appOL` the_default)
   where
          (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways
-         notd_ways = sortLe
-                        (\w1 w2 -> leAlt (fst w1) (fst w2))
-                        not_defaults
+         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
@@ -1368,22 +1395,6 @@ mkMultiBranch maybe_ncons raw_ways = do
                  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
 
@@ -1413,6 +1424,7 @@ data Discr
    | DiscrD Double
    | DiscrP Word16
    | NoDiscr
+    deriving (Eq, Ord)
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i
@@ -1426,13 +1438,36 @@ instance Outputable Discr where
 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"++
@@ -1476,24 +1511,24 @@ 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
@@ -1502,6 +1537,9 @@ 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
 
@@ -1509,7 +1547,8 @@ type BcPtr = Either ItblPtr (Ptr ())
 
 data BcM_State
    = BcM_State
-        { uniqSupply :: UniqSupply       -- for generating fresh variable names
+        { 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
@@ -1524,9 +1563,10 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: UniqSupply -> Module -> ModBreaks -> BcM r -> IO (BcM_State, r)
-runBc us this_mod modBreaks (BcM m)
-   = m (BcM_State us this_mod 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
 
@@ -1551,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))