Add Int8# and Word8#
authorMichal Terepeta <michal.terepeta@gmail.com>
Fri, 2 Nov 2018 18:27:03 +0000 (14:27 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 2 Nov 2018 21:15:01 +0000 (17:15 -0400)
This is the first step of implementing:
https://github.com/ghc-proposals/ghc-proposals/pull/74

The main highlights/changes:

    primops.txt.pp gets two new sections for two new primitive types for
    signed and unsigned 8-bit integers (Int8# and Word8 respectively) along
    with basic arithmetic and comparison operations. PrimRep/RuntimeRep get
    two new constructors for them. All of the primops translate into the
    existing MachOPs.

    For CmmCalls the codegen will now zero-extend the values at call
    site (so that they can be moved to the right register) and then truncate
    them back their original width.

    x86 native codegen needed some updates, since it wasn't able to deal
    with the new widths, but all the changes are quite localized. LLVM
    backend seems to just work.

This is the second attempt at merging this, after the first attempt in
D4475 had to be backed out due to regressions on i386.

Bumps binary submodule.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: ./validate (on both x86-{32,64})

Reviewers: bgamari, hvr, goldfire, simonmar

Subscribers: rwbarton, carter

Differential Revision: https://phabricator.haskell.org/D5258

44 files changed:
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmMachOp.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/MkGraph.hs
compiler/cmm/PprC.hs
compiler/codeGen/StgCmmArgRep.hs
compiler/codeGen/StgCmmPrim.hs
compiler/ghci/ByteCodeGen.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/nativeGen/X86/Instr.hs
compiler/nativeGen/X86/Ppr.hs
compiler/prelude/PrelNames.hs
compiler/prelude/TysPrim.hs
compiler/prelude/TysWiredIn.hs
compiler/prelude/TysWiredIn.hs-boot
compiler/prelude/primops.txt.pp
compiler/simplStg/RepType.hs
compiler/typecheck/TcGenDeriv.hs
compiler/types/TyCon.hs
compiler/utils/Binary.hs
includes/CodeGen.Platform.hs
libraries/base/Data/Typeable/Internal.hs
libraries/binary
libraries/ghc-prim/GHC/Types.hs
testsuite/tests/ffi/should_run/PrimFFIInt8.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/PrimFFIInt8.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/PrimFFIInt8_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/PrimFFIWord8.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/PrimFFIWord8.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/PrimFFIWord8_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/all.T
testsuite/tests/primops/should_run/ArithInt8.hs [new file with mode: 0644]
testsuite/tests/primops/should_run/ArithInt8.stdout [new file with mode: 0644]
testsuite/tests/primops/should_run/ArithWord8.hs [new file with mode: 0644]
testsuite/tests/primops/should_run/ArithWord8.stdout [new file with mode: 0644]
testsuite/tests/primops/should_run/CmpInt8.hs [new file with mode: 0644]
testsuite/tests/primops/should_run/CmpInt8.stdout [new file with mode: 0644]
testsuite/tests/primops/should_run/CmpWord8.hs [new file with mode: 0644]
testsuite/tests/primops/should_run/CmpWord8.stdout [new file with mode: 0644]
testsuite/tests/primops/should_run/ShowPrim.hs [new file with mode: 0644]
testsuite/tests/primops/should_run/ShowPrim.stdout [new file with mode: 0644]
testsuite/tests/primops/should_run/all.T
utils/genprimopcode/Main.hs

index d129d60..601b1d9 100644 (file)
@@ -6,7 +6,7 @@
 
 module CmmExpr
     ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
-    , CmmReg(..), cmmRegType
+    , CmmReg(..), cmmRegType, cmmRegWidth
     , CmmLit(..), cmmLitType
     , LocalReg(..), localRegType
     , GlobalReg(..), isArgReg, globalRegType
@@ -273,6 +273,9 @@ cmmRegType :: DynFlags -> CmmReg -> CmmType
 cmmRegType _      (CmmLocal  reg) = localRegType reg
 cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
 
+cmmRegWidth :: DynFlags -> CmmReg -> Width
+cmmRegWidth dflags = typeWidth . cmmRegType dflags
+
 localRegType :: LocalReg -> CmmType
 localRegType (LocalReg _ rep) = rep
 
index c5e9d9b..70e53d2 100644 (file)
@@ -107,6 +107,14 @@ data MachOp
   | MO_FS_Conv Width Width      -- Float -> Signed int
   | MO_SS_Conv Width Width      -- Signed int -> Signed int
   | MO_UU_Conv Width Width      -- unsigned int -> unsigned int
+  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the
+                                -- contents of upper bits when extending;
+                                -- narrowing is simply truncation; the only
+                                -- expectation is that we can recover the
+                                -- original value by applying the opposite
+                                -- MO_XX_Conv, e.g.,
+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+                                -- is equivalent to just x.
   | MO_FF_Conv Width Width      -- Float -> Float
 
   -- Vector element insertion and extraction operations
@@ -392,6 +400,7 @@ machOpResultType dflags mop tys =
 
     MO_SS_Conv _ to     -> cmmBits to
     MO_UU_Conv _ to     -> cmmBits to
+    MO_XX_Conv _ to     -> cmmBits to
     MO_FS_Conv _ to     -> cmmBits to
     MO_SF_Conv _ to     -> cmmFloat to
     MO_FF_Conv _ to     -> cmmFloat to
@@ -483,6 +492,7 @@ machOpArgReps dflags op =
 
     MO_SS_Conv from _   -> [from]
     MO_UU_Conv from _   -> [from]
+    MO_XX_Conv from _   -> [from]
     MO_SF_Conv from _   -> [from]
     MO_FS_Conv from _   -> [from]
     MO_FF_Conv from _   -> [from]
index 42d6484..11e4df5 100644 (file)
@@ -97,6 +97,8 @@ primRepCmmType dflags LiftedRep        = gcWord dflags
 primRepCmmType dflags UnliftedRep      = gcWord dflags
 primRepCmmType dflags IntRep           = bWord dflags
 primRepCmmType dflags WordRep          = bWord dflags
+primRepCmmType _      Int8Rep          = b8
+primRepCmmType _      Word8Rep         = b8
 primRepCmmType _      Int64Rep         = b64
 primRepCmmType _      Word64Rep        = b64
 primRepCmmType dflags AddrRep          = bWord dflags
@@ -131,8 +133,10 @@ primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
 primRepForeignHint LiftedRep    = AddrHint
 primRepForeignHint UnliftedRep  = AddrHint
 primRepForeignHint IntRep       = SignedHint
-primRepForeignHint WordRep      = NoHint
+primRepForeignHint Int8Rep      = SignedHint
 primRepForeignHint Int64Rep     = SignedHint
+primRepForeignHint WordRep      = NoHint
+primRepForeignHint Word8Rep     = NoHint
 primRepForeignHint Word64Rep    = NoHint
 primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
 primRepForeignHint FloatRep     = NoHint
index 70229d0..bcd03bf 100644 (file)
@@ -38,6 +38,7 @@ import OrdList
 import SMRep (ByteOff)
 import UniqSupply
 import Util
+import Panic
 
 
 -----------------------------------------------------------------------------
@@ -309,18 +310,33 @@ copyIn :: DynFlags -> Convention -> Area
 copyIn dflags conv area formals extra_stk
   = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
   where
-     ci (reg, RegisterParam r) =
-          CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
-     ci (reg, StackParam off) =
-          CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
-          where ty = localRegType reg
+    -- See Note [Width of parameters]
+    ci (reg, RegisterParam r@(VanillaReg {})) =
+        let local = CmmLocal reg
+            global = CmmReg (CmmGlobal r)
+            width = cmmRegWidth dflags local
+            expr
+                | width == wordWidth dflags = global
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+                | otherwise = panic "Parameter width greater than word width"
 
-     init_offset = widthInBytes (wordWidth dflags) -- infotable
+        in CmmAssign local expr
 
-     (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+    -- Non VanillaRegs
+    ci (reg, RegisterParam r) =
+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
 
-     (stk_size, args) = assignArgumentsPos dflags stk_off conv
-                                           localRegType formals
+    ci (reg, StackParam off) =
+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+         where ty = localRegType reg
+
+    init_offset = widthInBytes (wordWidth dflags) -- infotable
+
+    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+
+    (stk_size, args) = assignArgumentsPos dflags stk_off conv
+                                          localRegType formals
 
 -- Factoring out the common parts of the copyout functions yielded something
 -- more complicated:
@@ -346,8 +362,21 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
   where
     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
 
-    co (v, RegisterParam r) (rs, ms)
-       = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+    -- See Note [Width of parameters]
+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
+        let width = cmmExprWidth dflags v
+            value
+                | width == wordWidth dflags = v
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
+
+    -- Non VanillaRegs
+    co (v, RegisterParam r) (rs, ms) =
+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+
     co (v, StackParam off)  (rs, ms)
        = (rs, mkStore (CmmStackSlot area off) v <*> ms)
 
@@ -374,6 +403,28 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
                                           (cmmExprType dflags) actuals
 
 
+-- Note [Width of parameters]
+--
+-- Consider passing a small (< word width) primitive like Int8# to a function
+-- through a register. It's actually non-trivial to do this without
+-- extending/narrowing:
+-- * Global registers are considered to have native word width (i.e., 64-bits on
+--   x86-64), so CmmLint would complain if we assigne an 8-bit parameter to a
+--   global register.
+-- * Same problem exists with LLVM IR.
+-- * Lowering gets harder since on x86-32 not every register exposes its lower
+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
+--   8-bit register for %edi). So we would either need to extend/narrow anyway,
+--   or complicate the calling convention.
+-- So instead, we always extend every parameter smaller than native word width
+-- in copyOutOflow and then truncate it back to the expected width in copyIn.
+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
+-- zero-/sign-extending - it's up to a backend to handle this in a most
+-- efficient way (e.g., a simple register move)
+--
+-- There was some discussion about this on this PR:
+-- https://github.com/ghc-proposals/ghc-proposals/pull/74
+
 
 mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
             -> (Int, [GlobalReg], CmmAGraph)
index a979d49..17fef7f 100644 (file)
@@ -646,6 +646,9 @@ pprMachOp_for_C mop = case mop of
         MO_SS_Conv from to | from == to -> empty
         MO_SS_Conv _from to -> parens (machRep_S_CType to)
 
+        MO_XX_Conv from to | from == to -> empty
+        MO_XX_Conv _from to -> parens (machRep_U_CType to)
+
         MO_FF_Conv from to | from == to -> empty
         MO_FF_Conv _from to -> parens (machRep_F_CType to)
 
index 2ea0407..95f96dc 100644 (file)
@@ -70,6 +70,8 @@ toArgRep LiftedRep         = P
 toArgRep UnliftedRep       = P
 toArgRep IntRep            = N
 toArgRep WordRep           = N
+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls
+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls
 toArgRep AddrRep           = N
 toArgRep Int64Rep          = L
 toArgRep Word64Rep         = L
index c90264f..9da472e 100644 (file)
@@ -875,19 +875,29 @@ type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
 callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
 callishPrimOpSupported dflags op
   = case op of
-      IntQuotRemOp   | ncg && (x86ish
-                              || ppc) -> Left (MO_S_QuotRem  (wordWidth dflags))
-                     | otherwise      -> Right (genericIntQuotRemOp dflags)
+      IntQuotRemOp   | ncg && (x86ish || ppc) ->
+                         Left (MO_S_QuotRem  (wordWidth dflags))
+                     | otherwise              ->
+                         Right (genericIntQuotRemOp (wordWidth dflags))
 
-      WordQuotRemOp  | ncg && (x86ish
-                              || ppc) -> Left (MO_U_QuotRem  (wordWidth dflags))
-                     | otherwise      -> Right (genericWordQuotRemOp dflags)
+      Int8QuotRemOp  | (ncg && x86ish)
+                        || llvm      -> Left (MO_S_QuotRem W8)
+                     | otherwise     -> Right (genericIntQuotRemOp W8)
+
+      WordQuotRemOp  | ncg && (x86ish || ppc) ->
+                         Left (MO_U_QuotRem  (wordWidth dflags))
+                     | otherwise      ->
+                         Right (genericWordQuotRemOp (wordWidth dflags))
 
       WordQuotRem2Op | (ncg && (x86ish
                                 || ppc))
                           || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))
                      | otherwise      -> Right (genericWordQuotRem2Op dflags)
 
+      Word8QuotRemOp | (ncg && x86ish)
+                        || llvm      -> Left (MO_U_QuotRem W8)
+                     | otherwise     -> Right (genericWordQuotRemOp W8)
+
       WordAdd2Op     | (ncg && (x86ish
                                 || ppc))
                          || llvm      -> Left (MO_Add2       (wordWidth dflags))
@@ -943,20 +953,20 @@ callishPrimOpSupported dflags op
           ArchPPC_64 _ -> True
           _            -> False
 
-genericIntQuotRemOp :: DynFlags -> GenericOp
-genericIntQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
+genericIntQuotRemOp :: Width -> GenericOp
+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]
    = emit $ mkAssign (CmmLocal res_q)
-              (CmmMachOp (MO_S_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>
             mkAssign (CmmLocal res_r)
-              (CmmMachOp (MO_S_Rem  (wordWidth dflags)) [arg_x, arg_y])
+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])
 genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
 
-genericWordQuotRemOp :: DynFlags -> GenericOp
-genericWordQuotRemOp dflags [res_q, res_r] [arg_x, arg_y]
+genericWordQuotRemOp :: Width -> GenericOp
+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
     = emit $ mkAssign (CmmLocal res_q)
-               (CmmMachOp (MO_U_Quot (wordWidth dflags)) [arg_x, arg_y]) <*>
+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>
              mkAssign (CmmLocal res_r)
-               (CmmMachOp (MO_U_Rem  (wordWidth dflags)) [arg_x, arg_y])
+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])
 genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
 
 genericWordQuotRem2Op :: DynFlags -> GenericOp
@@ -1310,6 +1320,42 @@ translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)
 translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)
 translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)
 
+-- Int8# signed ops
+
+translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))
+translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)
+translateOp _      Int8NegOp      = Just (MO_S_Neg W8)
+translateOp _      Int8AddOp      = Just (MO_Add W8)
+translateOp _      Int8SubOp      = Just (MO_Sub W8)
+translateOp _      Int8MulOp      = Just (MO_Mul W8)
+translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)
+translateOp _      Int8RemOp      = Just (MO_S_Rem W8)
+
+translateOp _      Int8EqOp       = Just (MO_Eq W8)
+translateOp _      Int8GeOp       = Just (MO_S_Ge W8)
+translateOp _      Int8GtOp       = Just (MO_S_Gt W8)
+translateOp _      Int8LeOp       = Just (MO_S_Le W8)
+translateOp _      Int8LtOp       = Just (MO_S_Lt W8)
+translateOp _      Int8NeOp       = Just (MO_Ne W8)
+
+-- Word8# unsigned ops
+
+translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))
+translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)
+translateOp _      Word8NotOp      = Just (MO_Not W8)
+translateOp _      Word8AddOp      = Just (MO_Add W8)
+translateOp _      Word8SubOp      = Just (MO_Sub W8)
+translateOp _      Word8MulOp      = Just (MO_Mul W8)
+translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)
+translateOp _      Word8RemOp      = Just (MO_U_Rem W8)
+
+translateOp _      Word8EqOp       = Just (MO_Eq W8)
+translateOp _      Word8GeOp       = Just (MO_U_Ge W8)
+translateOp _      Word8GtOp       = Just (MO_U_Gt W8)
+translateOp _      Word8LeOp       = Just (MO_U_Le W8)
+translateOp _      Word8LtOp       = Just (MO_U_Lt W8)
+translateOp _      Word8NeOp       = Just (MO_Ne W8)
+
 -- Char# ops
 
 translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))
index 9aaaa7d..e723258 100644 (file)
@@ -805,7 +805,7 @@ mkConAppCode orig_d _ p con args_r_to_l =
 
             do_pushery !d (arg : args) = do
                 (push, arg_bytes) <- case arg of
-                    (Padding l _) -> pushPadding l
+                    (Padding l _) -> return $! pushPadding l
                     (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
                 more_push_code <- do_pushery (d + arg_bytes) args
                 return (push `appOL` more_push_code)
@@ -1570,11 +1570,16 @@ pushConstrAtom d p (AnnVar v)
 
 pushConstrAtom d p expr = pushAtom d p expr
 
-pushPadding :: Int -> BcM (BCInstrList, ByteOff)
-pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
-pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
-pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
-pushPadding x = panic $ "pushPadding x=" ++ show x
+pushPadding :: Int -> (BCInstrList, ByteOff)
+pushPadding !n = go n (nilOL, 0)
+  where
+    go n acc@(!instrs, !off) = case n of
+        0 -> acc
+        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)
+        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)
+        3 -> go 1 (go 2 acc)
+        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)
+        _ -> go (n - 4) (go 4 acc)
 
 -- -----------------------------------------------------------------------------
 -- Given a bunch of alts code and their discrs, do the donkey work
index 21abc65..efc8709 100644 (file)
@@ -1193,6 +1193,9 @@ genMachOp _ op [x] = case op of
     MO_UU_Conv from to
         -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
 
+    MO_XX_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Bitcast LM_Bitcast
+
     MO_FF_Conv from to
         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
 
@@ -1454,6 +1457,7 @@ genMachOp_slow opt op [x, y] = case op of
     MO_FS_Conv _ _ -> panicOp
     MO_SS_Conv _ _ -> panicOp
     MO_UU_Conv _ _ -> panicOp
+    MO_XX_Conv _ _ -> panicOp
     MO_FF_Conv _ _ -> panicOp
 
     MO_V_Insert  {} -> panicOp
index a2e26bd..38dc760 100644 (file)
@@ -644,20 +644,27 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
       -- Nop conversions
       MO_UU_Conv W32 W8  -> toI8Reg  W32 x
       MO_SS_Conv W32 W8  -> toI8Reg  W32 x
+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x
       MO_UU_Conv W16 W8  -> toI8Reg  W16 x
       MO_SS_Conv W16 W8  -> toI8Reg  W16 x
+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x
       MO_UU_Conv W32 W16 -> toI16Reg W32 x
       MO_SS_Conv W32 W16 -> toI16Reg W32 x
+      MO_XX_Conv W32 W16 -> toI16Reg W32 x
 
       MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x
       MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x
       MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
       MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
       MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
       MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
 
       MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
       MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
 
       -- widenings
       MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x
@@ -668,16 +675,32 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
       MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
       MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x
 
+      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
+      MO_XX_Conv W8  W32
+          | is32Bit   -> integerExtend W8 W32 MOVZxL x
+          | otherwise -> integerExtend W8 W32 MOV x
+      MO_XX_Conv W8  W16
+          | is32Bit   -> integerExtend W8 W16 MOVZxL x
+          | otherwise -> integerExtend W8 W16 MOV x
+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x
+
       MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x
       MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x
       MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x
       MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x
       MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x
       MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x
-        -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl.
-        -- However, we don't want the register allocator to throw it
-        -- away as an unnecessary reg-to-reg move, so we keep it in
-        -- the form of a movzl and print it as a movl later.
+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
+      -- However, we don't want the register allocator to throw it
+      -- away as an unnecessary reg-to-reg move, so we keep it in
+      -- the form of a movzl and print it as a movl later.
+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about
+      -- the upper bits. So we can just use MOV.
+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x
+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x
+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x
 
       MO_FF_Conv W32 W64
         | sse2      -> coerceFP2FP W64 x
@@ -787,6 +810,7 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
 
       MO_S_MulMayOflo rep -> imulMayOflo rep x y
 
+      MO_Mul W8  -> imulW8 x y
       MO_Mul rep -> triv_op rep IMUL
       MO_And rep -> triv_op rep AND
       MO_Or  rep -> triv_op rep OR
@@ -822,6 +846,21 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
     triv_op width instr = trivialCode width op (Just op) x y
                         where op   = instr (intFormat width)
 
+    -- Special case for IMUL for bytes, since the result of IMULB will be in
+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
+    -- values.
+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register
+    imulW8 arg_a arg_b = do
+        (a_reg, a_code) <- getNonClobberedReg arg_a
+        b_code <- getAnyReg arg_b
+
+        let code = a_code `appOL` b_code eax `appOL`
+                   toOL [ IMUL2 format (OpReg a_reg) ]
+            format = intFormat W8
+
+        return (Fixed format eax code)
+
+
     imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
     imulMayOflo rep a b = do
          (a_reg, a_code) <- getNonClobberedReg a
@@ -916,6 +955,18 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
         return (Any format code)
 
     ----------------------
+
+    -- See Note [DIV/IDIV for bytes]
+    div_code W8 signed quotient x y = do
+        let widen | signed    = MO_SS_Conv W8 W16
+                  | otherwise = MO_UU_Conv W8 W16
+        div_code
+            W16
+            signed
+            quotient
+            (CmmMachOp widen [x])
+            (CmmMachOp widen [y])
+
     div_code width signed quotient x y = do
            (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
            x_code <- getAnyReg x
@@ -2277,6 +2328,18 @@ genCCall _ is32Bit target dest_regs args = do
             = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
         divOp2 _ _ _ _ _
             = panic "genCCall: Wrong number of arguments for divOp2"
+
+        -- See Note [DIV/IDIV for bytes]
+        divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =
+            let widen | signed = MO_SS_Conv W8 W16
+                      | otherwise = MO_UU_Conv W8 W16
+                arg_x_low_16 = CmmMachOp widen [arg_x_low]
+                arg_y_16 = CmmMachOp widen [arg_y]
+                m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high
+            in divOp
+                  platform signed W16 [res_q, res_r]
+                  m_arg_x_high_16 arg_x_low_16 arg_y_16
+
         divOp platform signed width [res_q, res_r]
               m_arg_x_high arg_x_low arg_y
             = do let format = intFormat width
@@ -2318,6 +2381,22 @@ genCCall _ is32Bit target dest_regs args = do
         addSubIntC _ _ _ _ _ _ _ _
             = panic "genCCall: Wrong number of arguments/results for addSubIntC"
 
+-- Note [DIV/IDIV for bytes]
+--
+-- IDIV reminder:
+--   Size    Dividend   Divisor   Quotient    Remainder
+--   byte    %ax         r/m8      %al          %ah
+--   word    %dx:%ax     r/m16     %ax          %dx
+--   dword   %edx:%eax   r/m32     %eax         %edx
+--   qword   %rdx:%rax   r/m64     %rax         %rdx
+--
+-- We do a special case for the byte division because the current
+-- codegen doesn't deal well with accessing %ah register (also,
+-- accessing %ah in 64-bit mode is complicated because it cannot be an
+-- operand of many instructions). So we just widen operands to 16 bits
+-- and get the results from %al, %dl. This is not optimal, but a few
+-- register moves are probably not a huge deal when doing division.
+
 genCCall32' :: DynFlags
             -> ForeignTarget            -- function to call
             -> [CmmFormal]        -- where to put the result
@@ -2330,7 +2409,7 @@ genCCall32' dflags target dest_regs args = do
             -- Align stack to 16n for calls, assuming a starting stack
             -- alignment of 16n - word_size on procedure entry. Which we
             -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
-            sizes               = map (arg_size . cmmExprType dflags) (reverse args)
+            sizes               = map (arg_size_bytes . cmmExprType dflags) (reverse args)
             raw_arg_size        = sum sizes + wORD_SIZE dflags
             arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size
             tot_arg_size        = raw_arg_size + arg_pad_size - wORD_SIZE dflags
@@ -2421,8 +2500,9 @@ genCCall32' dflags target dest_regs args = do
                 assign_code dest_regs)
 
       where
-        arg_size :: CmmType -> Int  -- Width in bytes
-        arg_size ty = widthInBytes (typeWidth ty)
+        -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
+        arg_size_bytes :: CmmType -> Int
+        arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags))
 
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
@@ -2461,6 +2541,10 @@ genCCall32' dflags target dest_regs args = do
                            )
 
           | otherwise = do
+            -- Arguments can be smaller than 32-bit, but we still use @PUSH
+            -- II32@ - the usual calling conventions expect integers to be
+            -- 4-byte aligned.
+            ASSERT((typeWidth arg_ty) <= W32) return ()
             (operand, code) <- getOperand arg
             delta <- getDeltaNat
             setDeltaNat (delta-size)
@@ -2470,7 +2554,7 @@ genCCall32' dflags target dest_regs args = do
 
           where
              arg_ty = cmmExprType dflags arg
-             size = arg_size arg_ty -- Byte size
+             size = arg_size_bytes arg_ty -- Byte size
 
 genCCall64' :: DynFlags
             -> ForeignTarget      -- function to call
@@ -2700,7 +2784,10 @@ genCCall64' dflags target dest_regs args = do
              push_args rest code'
 
            | otherwise = do
-             ASSERT(width == W64) return ()
+             -- Arguments can be smaller than 64-bit, but we still use @PUSH
+             -- II64@ - the usual calling conventions expect integers to be
+             -- 8-byte aligned.
+             ASSERT(width <= W64) return ()
              (arg_op, arg_code) <- getOperand arg
              delta <- getDeltaNat
              setDeltaNat (delta-arg_size)
index c7000c9..8cc61ed 100644 (file)
@@ -383,7 +383,13 @@ x86_regUsageOfInstr platform instr
     SUB    _ src dst    -> usageRM src dst
     SBB    _ src dst    -> usageRM src dst
     IMUL   _ src dst    -> usageRM src dst
-    IMUL2  _ src       -> mkRU (eax:use_R src []) [eax,edx]
+
+    -- Result of IMULB will be in just in %ax
+    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]
+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
+    -- %ax/%eax/%rax.
+    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]
+
     MUL    _ src dst    -> usageRM src dst
     MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]
     DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
index 808d22a..acfae71 100644 (file)
@@ -328,7 +328,7 @@ pprReg f r
       (case i of {
          0 -> sLit "%al";     1 -> sLit "%bl";
          2 -> sLit "%cl";     3 -> sLit "%dl";
-        _  -> sLit "very naughty I386 byte register"
+        _  -> sLit $ "very naughty I386 byte register: " ++ show i
       })
 
     ppr32_reg_word i = ptext
@@ -365,7 +365,7 @@ pprReg f r
         10 -> sLit "%r10b";   11 -> sLit "%r11b";
         12 -> sLit "%r12b";   13 -> sLit "%r13b";
         14 -> sLit "%r14b";   15 -> sLit "%r15b";
-        _  -> sLit "very naughty x86_64 byte register"
+        _  -> sLit $ "very naughty x86_64 byte register: " ++ show i
       })
 
     ppr64_reg_word i = ptext
@@ -790,8 +790,11 @@ pprInstr (POP format op) = pprFormatOp (sLit "pop") format op
 -- pprInstr POPA = text "\tpopal"
 
 pprInstr NOP = text "\tnop"
+pprInstr (CLTD II8) = text "\tcbtw"
+pprInstr (CLTD II16) = text "\tcwtd"
 pprInstr (CLTD II32) = text "\tcltd"
 pprInstr (CLTD II64) = text "\tcqto"
+pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x
 
 pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
 
@@ -1077,9 +1080,6 @@ pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst
 pprInstr (CMPXCHG format src dst)
    = pprFormatOpOp (sLit "cmpxchg") format src dst
 
-pprInstr _
-        = panic "X86.Ppr.pprInstr: no match"
-
 
 pprTrigOp :: String -> Bool -> CLabel -> CLabel
           -> Reg -> Reg -> Format -> SDoc
index d69eaeb..46d4484 100644 (file)
@@ -1682,7 +1682,7 @@ addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey,
     byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,
     doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey,
     intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,
-    int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
+    int8PrimTyConKey, int32PrimTyConKey, int32TyConKey, int64PrimTyConKey, int64TyConKey,
     integerTyConKey, naturalTyConKey,
     listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,
     weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey,
@@ -1703,37 +1703,39 @@ floatTyConKey                           = mkPreludeTyConUnique 12
 funTyConKey                             = mkPreludeTyConUnique 13
 intPrimTyConKey                         = mkPreludeTyConUnique 14
 intTyConKey                             = mkPreludeTyConUnique 15
-int8TyConKey                            = mkPreludeTyConUnique 16
-int16TyConKey                           = mkPreludeTyConUnique 17
-int32PrimTyConKey                       = mkPreludeTyConUnique 18
-int32TyConKey                           = mkPreludeTyConUnique 19
-int64PrimTyConKey                       = mkPreludeTyConUnique 20
-int64TyConKey                           = mkPreludeTyConUnique 21
-integerTyConKey                         = mkPreludeTyConUnique 22
-naturalTyConKey                         = mkPreludeTyConUnique 23
-
-listTyConKey                            = mkPreludeTyConUnique 24
-foreignObjPrimTyConKey                  = mkPreludeTyConUnique 25
-maybeTyConKey                           = mkPreludeTyConUnique 26
-weakPrimTyConKey                        = mkPreludeTyConUnique 27
-mutableArrayPrimTyConKey                = mkPreludeTyConUnique 28
-mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 29
-orderingTyConKey                        = mkPreludeTyConUnique 30
-mVarPrimTyConKey                        = mkPreludeTyConUnique 31
-ratioTyConKey                           = mkPreludeTyConUnique 32
-rationalTyConKey                        = mkPreludeTyConUnique 33
-realWorldTyConKey                       = mkPreludeTyConUnique 34
-stablePtrPrimTyConKey                   = mkPreludeTyConUnique 35
-stablePtrTyConKey                       = mkPreludeTyConUnique 36
-eqTyConKey                              = mkPreludeTyConUnique 38
-heqTyConKey                             = mkPreludeTyConUnique 39
-arrayArrayPrimTyConKey                  = mkPreludeTyConUnique 40
-mutableArrayArrayPrimTyConKey           = mkPreludeTyConUnique 41
+int8PrimTyConKey                        = mkPreludeTyConUnique 16
+int8TyConKey                            = mkPreludeTyConUnique 17
+int16TyConKey                           = mkPreludeTyConUnique 18
+int32PrimTyConKey                       = mkPreludeTyConUnique 19
+int32TyConKey                           = mkPreludeTyConUnique 20
+int64PrimTyConKey                       = mkPreludeTyConUnique 21
+int64TyConKey                           = mkPreludeTyConUnique 22
+integerTyConKey                         = mkPreludeTyConUnique 23
+naturalTyConKey                         = mkPreludeTyConUnique 24
+
+listTyConKey                            = mkPreludeTyConUnique 25
+foreignObjPrimTyConKey                  = mkPreludeTyConUnique 26
+maybeTyConKey                           = mkPreludeTyConUnique 27
+weakPrimTyConKey                        = mkPreludeTyConUnique 28
+mutableArrayPrimTyConKey                = mkPreludeTyConUnique 29
+mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 30
+orderingTyConKey                        = mkPreludeTyConUnique 31
+mVarPrimTyConKey                        = mkPreludeTyConUnique 32
+ratioTyConKey                           = mkPreludeTyConUnique 33
+rationalTyConKey                        = mkPreludeTyConUnique 34
+realWorldTyConKey                       = mkPreludeTyConUnique 35
+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 36
+stablePtrTyConKey                       = mkPreludeTyConUnique 37
+eqTyConKey                              = mkPreludeTyConUnique 39
+heqTyConKey                             = mkPreludeTyConUnique 40
+arrayArrayPrimTyConKey                  = mkPreludeTyConUnique 41
+mutableArrayArrayPrimTyConKey           = mkPreludeTyConUnique 42
 
 statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     mutVarPrimTyConKey, ioTyConKey,
-    wordPrimTyConKey, wordTyConKey, word8TyConKey, word16TyConKey,
-    word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
+    wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,
+    word16TyConKey, word32PrimTyConKey, word32TyConKey,
+    word64PrimTyConKey, word64TyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
@@ -1750,24 +1752,25 @@ ioTyConKey                              = mkPreludeTyConUnique 57
 voidPrimTyConKey                        = mkPreludeTyConUnique 58
 wordPrimTyConKey                        = mkPreludeTyConUnique 59
 wordTyConKey                            = mkPreludeTyConUnique 60
-word8TyConKey                           = mkPreludeTyConUnique 61
-word16TyConKey                          = mkPreludeTyConUnique 62
-word32PrimTyConKey                      = mkPreludeTyConUnique 63
-word32TyConKey                          = mkPreludeTyConUnique 64
-word64PrimTyConKey                      = mkPreludeTyConUnique 65
-word64TyConKey                          = mkPreludeTyConUnique 66
-liftedConKey                            = mkPreludeTyConUnique 67
-unliftedConKey                          = mkPreludeTyConUnique 68
-anyBoxConKey                            = mkPreludeTyConUnique 69
-kindConKey                              = mkPreludeTyConUnique 70
-boxityConKey                            = mkPreludeTyConUnique 71
-typeConKey                              = mkPreludeTyConUnique 72
-threadIdPrimTyConKey                    = mkPreludeTyConUnique 73
-bcoPrimTyConKey                         = mkPreludeTyConUnique 74
-ptrTyConKey                             = mkPreludeTyConUnique 75
-funPtrTyConKey                          = mkPreludeTyConUnique 76
-tVarPrimTyConKey                        = mkPreludeTyConUnique 77
-compactPrimTyConKey                     = mkPreludeTyConUnique 78
+word8PrimTyConKey                       = mkPreludeTyConUnique 61
+word8TyConKey                           = mkPreludeTyConUnique 62
+word16TyConKey                          = mkPreludeTyConUnique 63
+word32PrimTyConKey                      = mkPreludeTyConUnique 64
+word32TyConKey                          = mkPreludeTyConUnique 65
+word64PrimTyConKey                      = mkPreludeTyConUnique 66
+word64TyConKey                          = mkPreludeTyConUnique 67
+liftedConKey                            = mkPreludeTyConUnique 68
+unliftedConKey                          = mkPreludeTyConUnique 69
+anyBoxConKey                            = mkPreludeTyConUnique 70
+kindConKey                              = mkPreludeTyConUnique 71
+boxityConKey                            = mkPreludeTyConUnique 72
+typeConKey                              = mkPreludeTyConUnique 73
+threadIdPrimTyConKey                    = mkPreludeTyConUnique 74
+bcoPrimTyConKey                         = mkPreludeTyConUnique 75
+ptrTyConKey                             = mkPreludeTyConUnique 76
+funPtrTyConKey                          = mkPreludeTyConUnique 77
+tVarPrimTyConKey                        = mkPreludeTyConUnique 78
+compactPrimTyConKey                     = mkPreludeTyConUnique 79
 
 -- dotnet interop
 objectTyConKey :: Unique
@@ -2041,7 +2044,7 @@ sumRepDataConKey                        = mkPreludeDataConUnique 73
 runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]
 liftedRepDataConKey :: Unique
 runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)
-  = map mkPreludeDataConUnique [74..82]
+  = map mkPreludeDataConUnique [74..84]
 
 unliftedRepDataConKeys = vecRepDataConKey :
                          tupleRepDataConKey :
@@ -2051,29 +2054,29 @@ unliftedRepDataConKeys = vecRepDataConKey :
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 -- VecCount
 vecCountDataConKeys :: [Unique]
-vecCountDataConKeys = map mkPreludeDataConUnique [83..88]
+vecCountDataConKeys = map mkPreludeDataConUnique [85..90]
 
 -- See Note [Wiring in RuntimeRep] in TysWiredIn
 -- VecElem
 vecElemDataConKeys :: [Unique]
-vecElemDataConKeys = map mkPreludeDataConUnique [89..98]
+vecElemDataConKeys = map mkPreludeDataConUnique [91..100]
 
 -- Typeable things
 kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,
     kindRepFunDataConKey, kindRepTYPEDataConKey,
     kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey
     :: Unique
-kindRepTyConAppDataConKey = mkPreludeDataConUnique 100
-kindRepVarDataConKey      = mkPreludeDataConUnique 101
-kindRepAppDataConKey      = mkPreludeDataConUnique 102
-kindRepFunDataConKey      = mkPreludeDataConUnique 103
-kindRepTYPEDataConKey     = mkPreludeDataConUnique 104
-kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105
-kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106
+kindRepTyConAppDataConKey = mkPreludeDataConUnique 101
+kindRepVarDataConKey      = mkPreludeDataConUnique 102
+kindRepAppDataConKey      = mkPreludeDataConUnique 103
+kindRepFunDataConKey      = mkPreludeDataConUnique 104
+kindRepTYPEDataConKey     = mkPreludeDataConUnique 105
+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 106
+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 107
 
 typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique
-typeLitSymbolDataConKey   = mkPreludeDataConUnique 107
-typeLitNatDataConKey      = mkPreludeDataConUnique 108
+typeLitSymbolDataConKey   = mkPreludeDataConUnique 108
+typeLitNatDataConKey      = mkPreludeDataConUnique 109
 
 
 ---------------- Template Haskell -------------------
index 339913b..7d04788 100644 (file)
@@ -66,6 +66,9 @@ module TysPrim(
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
 
+        int8PrimTyCon,          int8PrimTy,
+        word8PrimTyCon,         word8PrimTy,
+
         int32PrimTyCon,         int32PrimTy,
         word32PrimTyCon,        word32PrimTy,
 
@@ -87,8 +90,9 @@ import GhcPrelude
 import {-# SOURCE #-} TysWiredIn
   ( runtimeRepTy, unboxedTupleKind, liftedTypeKind
   , vecRepDataConTyCon, tupleRepDataConTyCon
-  , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy
-  , wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy
+  , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy
+  , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy
+  , addrRepDataConTy
   , floatRepDataConTy, doubleRepDataConTy
   , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy
   , vec64DataConTy
@@ -145,6 +149,7 @@ exposedPrimTyCons
     , doublePrimTyCon
     , floatPrimTyCon
     , intPrimTyCon
+    , int8PrimTyCon
     , int32PrimTyCon
     , int64PrimTyCon
     , bcoPrimTyCon
@@ -165,6 +170,7 @@ exposedPrimTyCons
     , proxyPrimTyCon
     , threadIdPrimTyCon
     , wordPrimTyCon
+    , word8PrimTyCon
     , word32PrimTyCon
     , word64PrimTyCon
 
@@ -188,12 +194,14 @@ mkBuiltInPrimTc fs unique tycon
                   BuiltInSyntax
 
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
+int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
 int32PrimTyConName            = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
 int64PrimTyConName            = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon
 wordPrimTyConName             = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon
+word8PrimTyConName            = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon
 word32PrimTyConName           = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon
 word64PrimTyConName           = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon
 addrPrimTyConName             = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
@@ -513,8 +521,10 @@ primRepToRuntimeRep rep = case rep of
   LiftedRep     -> liftedRepDataConTy
   UnliftedRep   -> unliftedRepDataConTy
   IntRep        -> intRepDataConTy
+  Int8Rep       -> int8RepDataConTy
   WordRep       -> wordRepDataConTy
   Int64Rep      -> int64RepDataConTy
+  Word8Rep      -> word8RepDataConTy
   Word64Rep     -> word64RepDataConTy
   AddrRep       -> addrRepDataConTy
   FloatRep      -> floatRepDataConTy
@@ -556,6 +566,11 @@ intPrimTy       = mkTyConTy intPrimTyCon
 intPrimTyCon :: TyCon
 intPrimTyCon    = pcPrimTyCon0 intPrimTyConName IntRep
 
+int8PrimTy :: Type
+int8PrimTy     = mkTyConTy int8PrimTyCon
+int8PrimTyCon :: TyCon
+int8PrimTyCon  = pcPrimTyCon0 int8PrimTyConName Int8Rep
+
 int32PrimTy :: Type
 int32PrimTy     = mkTyConTy int32PrimTyCon
 int32PrimTyCon :: TyCon
@@ -571,6 +586,11 @@ wordPrimTy      = mkTyConTy wordPrimTyCon
 wordPrimTyCon :: TyCon
 wordPrimTyCon   = pcPrimTyCon0 wordPrimTyConName WordRep
 
+word8PrimTy :: Type
+word8PrimTy     = mkTyConTy word8PrimTyCon
+word8PrimTyCon :: TyCon
+word8PrimTyCon  = pcPrimTyCon0 word8PrimTyConName Word8Rep
+
 word32PrimTy :: Type
 word32PrimTy    = mkTyConTy word32PrimTyCon
 word32PrimTyCon :: TyCon
index 78a8d8c..7ceeeff 100644 (file)
@@ -107,8 +107,9 @@ module TysWiredIn (
 
         vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,
 
-        liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
-        wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+        liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
+        wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
+        addrRepDataConTy,
         floatRepDataConTy, doubleRepDataConTy,
 
         vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
@@ -414,10 +415,18 @@ sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") s
 runtimeRepSimpleDataConNames :: [Name]
 runtimeRepSimpleDataConNames
   = zipWith3Lazy mk_special_dc_name
-      [ fsLit "LiftedRep", fsLit "UnliftedRep"
+      [ fsLit "LiftedRep"
+      , fsLit "UnliftedRep"
       , fsLit "IntRep"
-      , fsLit "WordRep", fsLit "Int64Rep", fsLit "Word64Rep"
-      , fsLit "AddrRep", fsLit "FloatRep", fsLit "DoubleRep" ]
+      , fsLit "WordRep"
+      , fsLit "Int8Rep"
+      , fsLit "Int64Rep"
+      , fsLit "Word8Rep"
+      , fsLit "Word64Rep"
+      , fsLit "AddrRep"
+      , fsLit "FloatRep"
+      , fsLit "DoubleRep"
+      ]
       runtimeRepSimpleDataConKeys
       runtimeRepSimpleDataCons
 
@@ -1170,8 +1179,8 @@ runtimeRepSimpleDataCons :: [DataCon]
 liftedRepDataCon :: DataCon
 runtimeRepSimpleDataCons@(liftedRepDataCon : _)
   = zipWithLazy mk_runtime_rep_dc
-    [ LiftedRep, UnliftedRep, IntRep, WordRep, Int64Rep
-    , Word64Rep, AddrRep, FloatRep, DoubleRep ]
+    [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int64Rep
+    , Word8Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ]
     runtimeRepSimpleDataConNames
   where
     mk_runtime_rep_dc primrep name
@@ -1179,11 +1188,13 @@ runtimeRepSimpleDataCons@(liftedRepDataCon : _)
 
 -- See Note [Wiring in RuntimeRep]
 liftedRepDataConTy, unliftedRepDataConTy,
-  intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
-  word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
+  intRepDataConTy, int8RepDataConTy, wordRepDataConTy, int64RepDataConTy,
+  word8RepDataConTy, word64RepDataConTy, addrRepDataConTy,
+  floatRepDataConTy, doubleRepDataConTy :: Type
 [liftedRepDataConTy, unliftedRepDataConTy,
-   intRepDataConTy, wordRepDataConTy, int64RepDataConTy,
-   word64RepDataConTy, addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
+   intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int64RepDataConTy,
+   word8RepDataConTy, word64RepDataConTy,
+   addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy]
   = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons
 
 vecCountTyCon :: TyCon
index 8cc83d7..b853290 100644 (file)
@@ -24,9 +24,9 @@ runtimeRepTy :: Type
 
 liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon
 
-liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy,
-  wordRepDataConTy, int64RepDataConTy, word64RepDataConTy, addrRepDataConTy,
-  floatRepDataConTy, doubleRepDataConTy :: Type
+liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy,
+  wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy,
+  addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type
 
 vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,
   vec64DataConTy :: Type
index 1d879c4..8fceec0 100644 (file)
@@ -344,6 +344,88 @@ primop   ISrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#
           in the range 0 to word size - 1 inclusive.}
 
 ------------------------------------------------------------------------
+section "Int8#"
+        {Operations on 8-bit integers.}
+------------------------------------------------------------------------
+
+primtype Int8#
+
+primop Int8Extend "extendInt8#" GenPrimOp Int8# -> Int#
+primop Int8Narrow "narrowInt8#" GenPrimOp Int# -> Int8#
+
+primop Int8NegOp "negateInt8#" Monadic Int8# -> Int8#
+
+primop Int8AddOp "plusInt8#" Dyadic Int8# -> Int8# -> Int8#
+  with
+    commutable = True
+
+primop Int8SubOp "subInt8#" Dyadic Int8# -> Int8# -> Int8#
+
+primop Int8MulOp "timesInt8#" Dyadic Int8# -> Int8# -> Int8#
+  with
+    commutable = True
+
+primop Int8QuotOp "quotInt8#" Dyadic Int8# -> Int8# -> Int8#
+  with
+    can_fail = True
+
+primop Int8RemOp "remInt8#" Dyadic Int8# -> Int8# -> Int8#
+  with
+    can_fail = True
+
+primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)
+  with
+    can_fail = True
+
+primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int#
+primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int#
+
+------------------------------------------------------------------------
+section "Word8#"
+        {Operations on 8-bit unsigned integers.}
+------------------------------------------------------------------------
+
+primtype Word8#
+
+primop Word8Extend "extendWord8#" GenPrimOp Word8# -> Word#
+primop Word8Narrow "narrowWord8#" GenPrimOp Word# -> Word8#
+
+primop Word8NotOp "notWord8#" Monadic Word8# -> Word8#
+
+primop Word8AddOp "plusWord8#" Dyadic Word8# -> Word8# -> Word8#
+  with
+    commutable = True
+
+primop Word8SubOp "subWord8#" Dyadic Word8# -> Word8# -> Word8#
+
+primop Word8MulOp "timesWord8#" Dyadic Word8# -> Word8# -> Word8#
+  with
+    commutable = True
+
+primop Word8QuotOp "quotWord8#" Dyadic Word8# -> Word8# -> Word8#
+  with
+    can_fail = True
+
+primop Word8RemOp "remWord8#" Dyadic Word8# -> Word8# -> Word8#
+  with
+    can_fail = True
+
+primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)
+  with
+    can_fail = True
+
+primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int#
+primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int#
+
+------------------------------------------------------------------------
 section "Word#"
         {Operations on native-sized unsigned words (32+ bits).}
 ------------------------------------------------------------------------
index 694aa4e..a5b8ea6 100644 (file)
@@ -228,6 +228,9 @@ layoutUbxSum sum_slots0 arg_slots0 =
 --   - Float slots: Shared between floating point types.
 --
 --   - Void slots: Shared between void types. Not used in sums.
+--
+-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit
+-- values, so that we can pack things more tightly.
 data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot
   deriving (Eq, Ord)
     -- Constructor order is important! If slot A could fit into slot B
@@ -255,8 +258,10 @@ primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep")
 primRepSlot LiftedRep   = PtrSlot
 primRepSlot UnliftedRep = PtrSlot
 primRepSlot IntRep      = WordSlot
-primRepSlot WordRep     = WordSlot
+primRepSlot Int8Rep     = WordSlot
 primRepSlot Int64Rep    = Word64Slot
+primRepSlot WordRep     = WordSlot
+primRepSlot Word8Rep    = WordSlot
 primRepSlot Word64Rep   = Word64Slot
 primRepSlot AddrRep     = WordSlot
 primRepSlot FloatRep    = FloatSlot
index 84147c6..f4a2385 100644 (file)
@@ -77,7 +77,7 @@ import FastString
 import Pair
 import Bag
 
-import Data.List  ( partition, intersperse )
+import Data.List  ( find, partition, intersperse )
 
 type BagDerivStuff = Bag DerivStuff
 
@@ -218,7 +218,7 @@ gen_Eq_binds loc tycon = do
           -- Using 'foldr1' here ensures that the derived code is correctly
           -- associated. See Trac #10859.
           where
-            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
+            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
 
 {-
 ************************************************************************
@@ -456,7 +456,7 @@ gen_Ord_binds loc tycon = do
     -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
     mkInnerEqAlt op data_con
       = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
-        mkCompareFields tycon op (dataConOrigArgTys data_con)
+        mkCompareFields op (dataConOrigArgTys data_con)
       where
         data_con_RDR = getRdrName data_con
         bs_needed    = take (dataConSourceArity data_con) bs_RDRs
@@ -466,17 +466,17 @@ gen_Ord_binds loc tycon = do
     -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
     mkTagCmp dflags op =
       untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
-        unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
+        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
 
-mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr GhcPs
+mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
 -- where the ai,bi have the given types
-mkCompareFields tycon op tys
+mkCompareFields op tys
   = go tys as_RDRs bs_RDRs
   where
     go []   _      _          = eqResult op
     go [ty] (a:_)  (b:_)
-      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
+      | isUnliftedType ty     = unliftedOrdOp ty op a b
       | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
     go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                   (ltResult op)
@@ -498,10 +498,10 @@ mkCompareFields tycon op tys
       where
         a_expr = nlHsVar a
         b_expr = nlHsVar b
-        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
 
-unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
-unliftedOrdOp tycon ty op a b
+unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
+unliftedOrdOp ty op a b
   = case op of
        OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
                                      ltTag_Expr eqTag_Expr gtTag_Expr
@@ -510,7 +510,7 @@ unliftedOrdOp tycon ty op a b
        OrdGE      -> wrap ge_op
        OrdGT      -> wrap gt_op
   where
-   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
    wrap prim_op = genPrimOpApp a_expr prim_op b_expr
    a_expr = nlHsVar a
    b_expr = nlHsVar b
@@ -1197,16 +1197,25 @@ gen_Show_binds get_fixity loc tycon
 
              show_arg :: RdrName -> Type -> LHsExpr GhcPs
              show_arg b arg_ty
-               | isUnliftedType arg_ty
-               -- See Note [Deriving and unboxed types] in TcDeriv
-               = nlHsApps compose_RDR [mk_shows_app boxed_arg,
-                                       mk_showString_app postfixMod]
-               | otherwise
-               = mk_showsPrec_app arg_prec arg
-                 where
-                   arg        = nlHsVar b
-                   boxed_arg  = box "Show" tycon arg arg_ty
-                   postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
+                 | isUnliftedType arg_ty
+                 -- See Note [Deriving and unboxed types] in TcDerivInfer
+                 = with_conv $
+                    nlHsApps compose_RDR
+                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]
+                 | otherwise
+                 = mk_showsPrec_app arg_prec arg
+               where
+                 arg        = nlHsVar b
+                 boxed_arg  = box "Show" arg arg_ty
+                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
+                 with_conv expr
+                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
+                        nested_compose_Expr
+                            [ mk_showString_app ("(" ++ conv ++ " ")
+                            , expr
+                            , mk_showString_app ")"
+                            ]
+                    | otherwise = expr
 
                 -- Fixity stuff
              is_infix = dataConIsInfix data_con
@@ -1442,10 +1451,13 @@ gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
     constr_RDR, dataType_RDR,
     eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
     eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
+    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
     eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
+    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
     eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
     eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
-    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
+    extendWord8_RDR, extendInt8_RDR :: RdrName
 gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
 gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
 toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
@@ -1474,12 +1486,24 @@ leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
 gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
 geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
 
+eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")
+ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )
+leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")
+gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )
+geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")
+
 eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
 ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
 leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
 gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
 geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
 
+eqWord8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")
+ltWord8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )
+leWord8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord8#")
+gtWord8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )
+geWord8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord8#")
+
 eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
 ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
 leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
@@ -1498,6 +1522,10 @@ leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
 gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
 geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
 
+extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")
+extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1555,7 +1583,7 @@ gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
                                                   (nlHsVar a)
               | otherwise = nlHsApp (nlHsVar litE_RDR)
                               (primLitOp (mkBoxExp (nlHsVar a)))
-              where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
+              where (primLitOp, mkBoxExp) = primLitOps "Lift" ty
 
             pkg_name = unitIdString . moduleUnitId
                      . nameModule $ tycon_name
@@ -2076,55 +2104,60 @@ mkRdrFunBindSE arity
 
 
 box ::         String           -- The class involved
-            -> TyCon            -- The tycon involved
             -> LHsExpr GhcPs    -- The argument
             -> Type             -- The argument type
             -> LHsExpr GhcPs    -- Boxed version of the arg
--- See Note [Deriving and unboxed types] in TcDeriv
-box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
-  where
-    box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
 
 ---------------------
 primOrdOps :: String    -- The class involved
-           -> TyCon     -- The tycon involved
            -> Type      -- The type
            -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
--- See Note [Deriving and unboxed types] in TcDeriv
-primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+primOrdOps str ty = assoc_ty_id str ordOpTbl ty
 
 primLitOps :: String -- The class involved
-           -> TyCon  -- The tycon involved
            -> Type   -- The type
            -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
               , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
               )
-primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
-                          , \v -> nlHsVar boxRDR `nlHsApp` v
-                          )
+primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)
   where
-    boxRDR
-      | ty `eqType` addrPrimTy = unpackCString_RDR
-      | otherwise = assoc_ty_id str tycon boxConTbl ty
+    boxed v
+      | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v
+      | otherwise = assoc_ty_id str boxConTbl ty v
 
 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
 ordOpTbl
  =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR  , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
     ,(intPrimTy   , (ltInt_RDR   , leInt_RDR   , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
+    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR  , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))
     ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR  , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
+    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))
     ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR  , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
     ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
     ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
 
-boxConTbl :: [(Type, RdrName)]
-boxConTbl
-  = [(charPrimTy  , getRdrName charDataCon  )
-    ,(intPrimTy   , getRdrName intDataCon   )
-    ,(wordPrimTy  , getRdrName wordDataCon  )
-    ,(floatPrimTy , getRdrName floatDataCon )
-    ,(doublePrimTy, getRdrName doubleDataCon)
+-- A mapping from a primitive type to a function that constructs its boxed
+-- version.
+-- NOTE: Int8#/Word8# will become Int/Word.
+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+boxConTbl =
+    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
+    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))
+    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
+    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
+    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
+    , (int8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt8_RDR))
+    , (word8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord8_RDR))
     ]
 
+
 -- | A table of postfix modifiers for unboxed values.
 postfixModTbl :: [(Type, String)]
 postfixModTbl
@@ -2133,6 +2166,14 @@ postfixModTbl
     ,(wordPrimTy  , "##")
     ,(floatPrimTy , "#" )
     ,(doublePrimTy, "##")
+    ,(int8PrimTy, "#")
+    ,(word8PrimTy, "##")
+    ]
+
+primConvTbl :: [(Type, String)]
+primConvTbl =
+    [ (int8PrimTy, "narrowInt8#")
+    , (word8PrimTy, "narrowWord8#")
     ]
 
 litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
@@ -2156,17 +2197,20 @@ litConTbl
     ]
 
 -- | Lookup `Type` in an association list.
-assoc_ty_id :: String           -- The class involved
-            -> TyCon            -- The tycon involved
+assoc_ty_id :: HasCallStack => String           -- The class involved
             -> [(Type,a)]       -- The table
             -> Type             -- The type
             -> a                -- The result of the lookup
-assoc_ty_id cls_str _ tbl ty
-  | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
-                                              text "for primitive type" <+> ppr ty)
-  | otherwise = head res
-  where
-    res = [id | (ty',id) <- tbl, ty `eqType` ty']
+assoc_ty_id cls_str tbl ty
+  | Just a <- assoc_ty_id_maybe tbl ty = a
+  | otherwise =
+      pprPanic "Error in deriving:"
+          (text "Can't derive" <+> text cls_str <+>
+           text "for primitive type" <+> ppr ty)
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
 
 -----------------------------------------------------------------------
 
@@ -2175,12 +2219,12 @@ and_Expr a b = genOpApp a and_RDR    b
 
 -----------------------------------------------------------------------
 
-eq_Expr :: TyCon -> Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-eq_Expr tycon ty a b
+eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+eq_Expr ty a b
     | not (isUnliftedType ty) = genOpApp a eq_RDR b
     | otherwise               = genPrimOpApp a prim_eq b
  where
-   (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
+   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
 
 untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
               -> LHsExpr GhcPs -> LHsExpr GhcPs
index eeebf8b..7322a16 100644 (file)
@@ -1325,9 +1325,11 @@ data PrimRep
   = VoidRep
   | LiftedRep
   | UnliftedRep   -- ^ Unlifted pointer
+  | Int8Rep       -- ^ Signed, 8-bit value
   | IntRep        -- ^ Signed, word-sized value
   | WordRep       -- ^ Unsigned, word-sized value
   | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)
+  | Word8Rep      -- ^ Unsigned, 8 bit value
   | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)
   | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
   | FloatRep
@@ -1373,7 +1375,9 @@ isGcPtrRep _           = False
 primRepSizeB :: DynFlags -> PrimRep -> Int
 primRepSizeB dflags IntRep           = wORD_SIZE dflags
 primRepSizeB dflags WordRep          = wORD_SIZE dflags
+primRepSizeB _      Int8Rep          = 1
 primRepSizeB _      Int64Rep         = wORD64_SIZE
+primRepSizeB _      Word8Rep         = 1
 primRepSizeB _      Word64Rep        = wORD64_SIZE
 primRepSizeB _      FloatRep         = fLOAT_SIZE
 primRepSizeB dflags DoubleRep        = dOUBLE_SIZE dflags
index 447317c..a38af74 100644 (file)
@@ -637,6 +637,10 @@ instance Binary RuntimeRep where
     put_ bh AddrRep         = putByte bh 9
     put_ bh FloatRep        = putByte bh 10
     put_ bh DoubleRep       = putByte bh 11
+#if __GLASGOW_HASKELL__ >= 807
+    put_ bh Int8Rep         = putByte bh 12
+    put_ bh Word8Rep        = putByte bh 13
+#endif
 
     get bh = do
         tag <- getByte bh
@@ -653,6 +657,10 @@ instance Binary RuntimeRep where
           9  -> pure AddrRep
           10 -> pure FloatRep
           11 -> pure DoubleRep
+#if __GLASGOW_HASKELL__ >= 807
+          12 -> pure Int8Rep
+          13 -> pure Word8Rep
+#endif
           _  -> fail "Binary.putRuntimeRep: invalid tag"
 
 instance Binary KindRep where
index 8e93690..664942d 100644 (file)
@@ -837,15 +837,16 @@ freeReg :: RegNo -> Bool
 
 # if defined(MACHREGS_i386)
 freeReg esp = False -- %esp is the C stack pointer
-freeReg esi = False -- Note [esi/edi not allocatable]
+freeReg esi = False -- Note [esi/edi/ebp not allocatable]
 freeReg edi = False
+freeReg ebp = False
 # endif
 # if defined(MACHREGS_x86_64)
 freeReg rsp = False  --        %rsp is the C stack pointer
 # endif
 
 {-
-Note [esi/edi not allocatable]
+Note [esi/edi/ebp not allocatable]
 
 %esi is mapped to R1, so %esi would normally be allocatable while it
 is not being used for R1.  However, %esi has no 8-bit version on x86,
@@ -855,7 +856,7 @@ graph-colouring allocator also cannot handle this - it was designed
 with more flexibility in mind, but the current implementation is
 restricted to the same set of classes as the linear allocator.
 
-Hence, on x86 esi and edi are treated as not allocatable.
+Hence, on x86 esi, edi and ebp are treated as not allocatable.
 -}
 
 -- split patterns in two functions to prevent overlaps
index 06d225a..cc295b3 100644 (file)
@@ -664,8 +664,10 @@ runtimeRepTypeRep r =
       SumRep rs   -> kindedTypeRep @_ @'SumRep
                      `kApp` buildList (map runtimeRepTypeRep rs)
       IntRep      -> rep @'IntRep
-      WordRep     -> rep @'WordRep
+      Int8Rep     -> rep @'Int8Rep
       Int64Rep    -> rep @'Int64Rep
+      WordRep     -> rep @'WordRep
+      Word8Rep    -> rep @'Word8Rep
       Word64Rep   -> rep @'Word64Rep
       AddrRep     -> rep @'AddrRep
       FloatRep    -> rep @'FloatRep
index 38adf7c..0318374 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 38adf7ce1ad6a497fba61de500c3f35b186303a9
+Subproject commit 0318374b832ebe52a8d01bff2dd7bab8e747fbd4
index d06c0be..7ab8706 100644 (file)
@@ -394,8 +394,10 @@ data RuntimeRep = VecRep VecCount VecElem   -- ^ a SIMD vector type
                 | LiftedRep       -- ^ lifted; represented by a pointer
                 | UnliftedRep     -- ^ unlifted; represented by a pointer
                 | IntRep          -- ^ signed, word-sized value
-                | WordRep         -- ^ unsigned, word-sized value
+                | Int8Rep         -- ^ signed, 8-bit value
                 | Int64Rep        -- ^ signed, 64-bit value (on 32-bit only)
+                | WordRep         -- ^ unsigned, word-sized value
+                | Word8Rep        -- ^ unsigned, 8-bit value
                 | Word64Rep       -- ^ unsigned, 64-bit value (on 32-bit only)
                 | AddrRep         -- ^ A pointer, but /not/ to a Haskell value
                 | FloatRep        -- ^ a 32-bit floating point number
diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.hs b/testsuite/tests/ffi/should_run/PrimFFIInt8.hs
new file mode 100644 (file)
index 0000000..4124e07
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import GHC.Exts
+
+foreign import ccall "add_all_int8"
+    add_all_int8
+        :: Int8# -> Int8# -> Int8# -> Int8# -> Int8#
+        -> Int8# -> Int8# -> Int8# -> Int8# -> Int8#
+        -> Int8#
+
+main :: IO ()
+main = do
+    let a = narrowInt8# 0#
+        b = narrowInt8# 1#
+        c = narrowInt8# 2#
+        d = narrowInt8# 3#
+        e = narrowInt8# 4#
+        f = narrowInt8# 5#
+        g = narrowInt8# 6#
+        h = narrowInt8# 7#
+        i = narrowInt8# 8#
+        j = narrowInt8# 9#
+        x = I# (extendInt8# (add_all_int8 a b c d e f g h i j))
+    print x
diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout b/testsuite/tests/ffi/should_run/PrimFFIInt8.stdout
new file mode 100644 (file)
index 0000000..ea90ee3
--- /dev/null
@@ -0,0 +1 @@
+45
diff --git a/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c b/testsuite/tests/ffi/should_run/PrimFFIInt8_c.c
new file mode 100644 (file)
index 0000000..dc51687
--- /dev/null
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+int8_t add_all_int8(
+        int8_t a, int8_t b, int8_t c, int8_t d, int8_t e,
+        int8_t f, int8_t g, int8_t h, int8_t i, int8_t j) {
+    return a + b + c + d + e + f + g + h + i + j;
+}
diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.hs b/testsuite/tests/ffi/should_run/PrimFFIWord8.hs
new file mode 100644 (file)
index 0000000..87e4663
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import GHC.Exts
+
+foreign import ccall "add_all_word8"
+    add_all_word8
+        :: Word8# -> Word8# -> Word8# -> Word8# -> Word8#
+        -> Word8# -> Word8# -> Word8# -> Word8# -> Word8#
+        -> Word8#
+
+main :: IO ()
+main = do
+    let a = narrowWord8# 0##
+        b = narrowWord8# 1##
+        c = narrowWord8# 2##
+        d = narrowWord8# 3##
+        e = narrowWord8# 4##
+        f = narrowWord8# 5##
+        g = narrowWord8# 6##
+        h = narrowWord8# 7##
+        i = narrowWord8# 8##
+        j = narrowWord8# 9##
+        x = W# (extendWord8# (add_all_word8 a b c d e f g h i j))
+    print x
diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout b/testsuite/tests/ffi/should_run/PrimFFIWord8.stdout
new file mode 100644 (file)
index 0000000..ea90ee3
--- /dev/null
@@ -0,0 +1 @@
+45
diff --git a/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c b/testsuite/tests/ffi/should_run/PrimFFIWord8_c.c
new file mode 100644 (file)
index 0000000..535ed41
--- /dev/null
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+uint8_t add_all_word8(
+        uint8_t a, uint8_t b, uint8_t c, uint8_t d, uint8_t e,
+        uint8_t f, uint8_t g, uint8_t h, uint8_t i, uint8_t j) {
+    return a + b + c + d + e + f + g + h + i + j;
+}
index fd0af7e..9223b3d 100644 (file)
@@ -188,3 +188,7 @@ test('ffi023', [ omit_ways(['ghci']),
 test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c'])
 
 test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c'])
+
+test('PrimFFIInt8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt8_c.c'])
+
+test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c'])
diff --git a/testsuite/tests/primops/should_run/ArithInt8.hs b/testsuite/tests/primops/should_run/ArithInt8.hs
new file mode 100644 (file)
index 0000000..77f4cea
--- /dev/null
@@ -0,0 +1,201 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import Data.Int
+import Data.List
+import GHC.Prim
+import GHC.Exts
+
+main :: IO ()
+main = do
+
+    --
+    -- Check if passing Int8# on the stack works (16 parameter function will
+    -- need to use stack for some of the them)
+    --
+    let input =
+            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
+                (a + 4), (a + 5), (a + 6), (a + 7),
+                (a + 8), (a + 9), (a + 10), (a + 11),
+                (a + 12), (a + 13), (a + 14), (a + 15) )
+            | a <- allInt8
+            ]
+        expected =
+            [ toInt8
+                  (a + b + c + d + e + f + g + h +
+                   i + j + k + l + m + n + o + p)
+            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
+            ]
+        actual =
+            [ addMany a b c d e f g h i j k l m n o p
+            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
+            ]
+    checkResults "passing Int8# on the stack" input expected actual
+
+    --
+    -- negateInt8#
+    --
+    let input = allInt8
+        expected = [ toInt8 (negate a) | a <- input ]
+        actual = [ apply1 negateInt8# a | a <- input ]
+    checkResults "negateInt8#" input expected actual
+
+    --
+    -- plusInt8#
+    --
+    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
+        expected = [ toInt8 (a + b) | (a, b) <- input ]
+        actual = [ apply2 plusInt8# a b | (a, b) <- input ]
+    checkResults "plusInt8#" input expected actual
+
+    --
+    -- subInt8#
+    --
+    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
+        expected = [ toInt8 (a - b) | (a, b) <- input ]
+        actual = [ apply2 subInt8# a b | (a, b) <- input ]
+    checkResults "subInt8#" input expected actual
+
+    --
+    -- timesInt8#
+    --
+    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
+        expected = [ toInt8 (a * b) | (a, b) <- input ]
+        actual = [ apply2 timesInt8# a b | (a, b) <- input ]
+    checkResults "timesInt8#" input expected actual
+
+    --
+    -- remInt8#
+    --
+    let input =
+            [ (a, b) | a <- allInt8, b <- allInt8
+            -- Don't divide by 0 or cause overflow
+            , b /= 0, not (a == -128 && b == -1)
+            ]
+        expected = [ toInt8 (a `rem` b) | (a, b) <- input ]
+        actual = [ apply2 remInt8# a b | (a, b) <- input ]
+    checkResults "remInt8#" input expected actual
+
+    --
+    -- quotInt8#
+    --
+    let input =
+            [ (a, b) | a <- allInt8, b <- allInt8
+            , b /= 0, not (a == -128 && b == -1)
+            ]
+        expected = [ toInt8 (a `quot` b) | (a, b) <- input ]
+        actual = [ apply2 quotInt8# a b | (a, b) <- input ]
+    checkResults "quotInt8#" input expected actual
+
+    --
+    -- quotRemInt8#
+    --
+    let input =
+            [ (a, b) | a <- allInt8, b <- allInt8
+            , b /= 0, not (a == -128 && b == -1)
+            ]
+        expected =
+            [ (toInt8 q, toInt8 r)  | (a, b) <- input
+            , let (q, r) = a `quotRem` b
+            ]
+        actual = [ apply3 quotRemInt8# a b | (a, b) <- input ]
+    checkResults "quotRemInt8#" input expected actual
+
+
+checkResults
+    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
+checkResults test inputs expected actual =
+    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
+        Nothing -> putStrLn $ "Pass: " ++ test
+        Just i -> error $
+            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
+              ++ " expected: " ++ show (expected !! i)
+              ++ " but got: " ++ show (actual !! i)
+
+allInt8 :: [Int]
+allInt8 = [ minInt8 .. maxInt8 ]
+
+minInt8 :: Int
+minInt8 = fromIntegral (minBound :: Int8)
+
+maxInt8 :: Int
+maxInt8 = fromIntegral (maxBound :: Int8)
+
+toInt8 :: Int -> Int
+toInt8 a = fromIntegral (fromIntegral a :: Int8)
+
+addMany#
+    :: Int8# -> Int8# -> Int8# -> Int8#
+    -> Int8# -> Int8# -> Int8# -> Int8#
+    -> Int8# -> Int8# -> Int8# -> Int8#
+    -> Int8# -> Int8# -> Int8# -> Int8#
+    -> Int8#
+addMany# a b c d e f g h i j k l m n o p =
+    a `plusInt8#` b `plusInt8#` c `plusInt8#` d `plusInt8#`
+    e `plusInt8#` f `plusInt8#` g `plusInt8#` h `plusInt8#`
+    i `plusInt8#` j `plusInt8#` k `plusInt8#` l `plusInt8#`
+    m `plusInt8#` n `plusInt8#` o `plusInt8#` p
+{-# NOINLINE addMany# #-}
+
+addMany
+    :: Int -> Int -> Int -> Int
+    -> Int -> Int -> Int -> Int
+    -> Int -> Int -> Int -> Int
+    -> Int -> Int -> Int -> Int
+    -> Int
+addMany (I# a) (I# b) (I# c) (I# d)
+        (I# e) (I# f) (I# g) (I# h)
+        (I# i) (I# j) (I# k) (I# l)
+        (I# m) (I# n) (I# o) (I# p)
+            = I# (extendInt8# int8)
+  where
+    !int8 = addMany#
+                (narrowInt8# a) (narrowInt8# b) (narrowInt8# c) (narrowInt8# d)
+                (narrowInt8# e) (narrowInt8# f) (narrowInt8# g) (narrowInt8# h)
+                (narrowInt8# i) (narrowInt8# j) (narrowInt8# k) (narrowInt8# l)
+                (narrowInt8# m) (narrowInt8# n) (narrowInt8# o) (narrowInt8# p)
+{-# NOINLINE addMany #-}
+
+-- Convenient and also tests higher order functions on Int8#
+apply1 :: (Int8# -> Int8#) -> Int -> Int
+apply1 opToTest (I# a) = I# (extendInt8# (opToTest (narrowInt8# a)))
+{-# NOINLINE apply1 #-}
+
+apply2 :: (Int8# -> Int8# -> Int8#) -> Int -> Int -> Int
+apply2 opToTest (I# a) (I# b) =
+    let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #)
+        r = opToTest sa sb
+    in I# (extendInt8# r)
+{-# NOINLINE apply2 #-}
+
+apply3 :: (Int8# -> Int8# -> (# Int8#, Int8# #)) -> Int -> Int -> (Int, Int)
+apply3 opToTest (I# a) (I# b) =
+    let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #)
+        (# ra, rb #) = opToTest sa sb
+    in (I# (extendInt8# ra), I# (extendInt8# rb))
+{-# NOINLINE apply3 #-}
+
+instance
+        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
+         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
+      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
+    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
+        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
+            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
+            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
+            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
+            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2
+
+instance
+        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
+         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
+      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
+    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
+        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
+        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
+        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
+        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
+        ")"
diff --git a/testsuite/tests/primops/should_run/ArithInt8.stdout b/testsuite/tests/primops/should_run/ArithInt8.stdout
new file mode 100644 (file)
index 0000000..16990fb
--- /dev/null
@@ -0,0 +1,8 @@
+Pass: passing Int8# on the stack
+Pass: negateInt8#
+Pass: plusInt8#
+Pass: subInt8#
+Pass: timesInt8#
+Pass: remInt8#
+Pass: quotInt8#
+Pass: quotRemInt8#
diff --git a/testsuite/tests/primops/should_run/ArithWord8.hs b/testsuite/tests/primops/should_run/ArithWord8.hs
new file mode 100644 (file)
index 0000000..ceac789
--- /dev/null
@@ -0,0 +1,198 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import Data.Word
+import Data.Bits
+import Data.List
+import GHC.Prim
+import GHC.Exts
+
+main :: IO ()
+main = do
+
+    --
+    -- Check if passing Word8# on the stack works (16 parameter function will
+    -- need to use stack for some of the them)
+    --
+    let input =
+            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
+                (a + 4), (a + 5), (a + 6), (a + 7),
+                (a + 8), (a + 9), (a + 10), (a + 11),
+                (a + 12), (a + 13), (a + 14), (a + 15) )
+            | a <- allWord8
+            ]
+        expected =
+            [ toWord8
+                  (a + b + c + d + e + f + g + h +
+                   i + j + k + l + m + n + o + p)
+            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
+            ]
+        actual =
+            [ addMany a b c d e f g h i j k l m n o p
+            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
+            ]
+    checkResults "passing Word8# on the stack" input expected actual
+
+    --
+    -- notWord8#
+    --
+    let input = allWord8
+        expected = [ toWord8 (complement a) | a <- input ]
+        actual = [ apply1 notWord8# a | a <- input ]
+    checkResults "notWord8#" input expected actual
+
+    --
+    -- plusWord8#
+    --
+    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
+        expected = [ toWord8 (a + b) | (a, b) <- input ]
+        actual = [ apply2 plusWord8# a b | (a, b) <- input ]
+    checkResults "plusWord8#" input expected actual
+
+    --
+    -- subWord8#
+    --
+    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
+        expected = [ toWord8 (a - b) | (a, b) <- input ]
+        actual = [ apply2 subWord8# a b | (a, b) <- input ]
+    checkResults "subWord8#" input expected actual
+
+    --
+    -- timesWord8#
+    --
+    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
+        expected = [ toWord8 (a * b) | (a, b) <- input ]
+        actual = [ apply2 timesWord8# a b | (a, b) <- input ]
+    checkResults "timesWord8#" input expected actual
+
+    --
+    -- remWord8#
+    --
+    let input =
+            -- Don't divide by 0.
+            [ (a, b) | a <- allWord8, b <- allWord8 , b /= 0 ]
+        expected = [ toWord8 (a `rem` b) | (a, b) <- input ]
+        actual = [ apply2 remWord8# a b | (a, b) <- input ]
+    checkResults "remWord8#" input expected actual
+
+    --
+    -- quotWord8#
+    --
+    let input =
+            [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ]
+        expected = [ toWord8 (a `quot` b) | (a, b) <- input ]
+        actual = [ apply2 quotWord8# a b | (a, b) <- input ]
+    checkResults "quotWord8#" input expected actual
+
+    --
+    -- quotRemWord8#
+    --
+    let input =
+            [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ]
+        expected =
+            [ (toWord8 q, toWord8 r)  | (a, b) <- input
+            , let (q, r) = a `quotRem` b
+            ]
+        actual = [ apply3 quotRemWord8# a b | (a, b) <- input ]
+    checkResults "quotRemWord8#" input expected actual
+
+
+checkResults
+    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
+checkResults test inputs expected actual =
+    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
+        Nothing -> putStrLn $ "Pass: " ++ test
+        Just i -> error $
+            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
+              ++ " expected: " ++ show (expected !! i)
+              ++ " but got: " ++ show (actual !! i)
+
+allWord8 :: [Word]
+allWord8 = [ minWord8 .. maxWord8 ]
+
+minWord8 :: Word
+minWord8 = fromIntegral (minBound :: Word8)
+
+maxWord8 :: Word
+maxWord8 = fromIntegral (maxBound :: Word8)
+
+toWord8 :: Word -> Word
+toWord8 a = fromIntegral (fromIntegral a :: Word8)
+
+addMany#
+    :: Word8# -> Word8# -> Word8# -> Word8#
+    -> Word8# -> Word8# -> Word8# -> Word8#
+    -> Word8# -> Word8# -> Word8# -> Word8#
+    -> Word8# -> Word8# -> Word8# -> Word8#
+    -> Word8#
+addMany# a b c d e f g h i j k l m n o p =
+    a `plusWord8#` b `plusWord8#` c `plusWord8#` d `plusWord8#`
+    e `plusWord8#` f `plusWord8#` g `plusWord8#` h `plusWord8#`
+    i `plusWord8#` j `plusWord8#` k `plusWord8#` l `plusWord8#`
+    m `plusWord8#` n `plusWord8#` o `plusWord8#` p
+{-# NOINLINE addMany# #-}
+
+addMany
+    :: Word -> Word -> Word -> Word
+    -> Word -> Word -> Word -> Word
+    -> Word -> Word -> Word -> Word
+    -> Word -> Word -> Word -> Word
+    -> Word
+addMany (W# a) (W# b) (W# c) (W# d)
+        (W# e) (W# f) (W# g) (W# h)
+        (W# i) (W# j) (W# k) (W# l)
+        (W# m) (W# n) (W# o) (W# p)
+            = W# (extendWord8# word8)
+  where
+    !word8 =
+        addMany#
+            (narrowWord8# a) (narrowWord8# b) (narrowWord8# c) (narrowWord8# d)
+            (narrowWord8# e) (narrowWord8# f) (narrowWord8# g) (narrowWord8# h)
+            (narrowWord8# i) (narrowWord8# j) (narrowWord8# k) (narrowWord8# l)
+            (narrowWord8# m) (narrowWord8# n) (narrowWord8# o) (narrowWord8# p)
+{-# NOINLINE addMany #-}
+
+-- Convenient and also tests higher order functions on Word8#
+apply1 :: (Word8# -> Word8#) -> Word -> Word
+apply1 opToTest (W# a) = W# (extendWord8# (opToTest (narrowWord8# a)))
+{-# NOINLINE apply1 #-}
+
+apply2 :: (Word8# -> Word8# -> Word8#) -> Word -> Word -> Word
+apply2 opToTest (W# a) (W# b) =
+    let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #)
+        r = opToTest sa sb
+    in W# (extendWord8# r)
+{-# NOINLINE apply2 #-}
+
+apply3
+  :: (Word8# -> Word8# -> (# Word8#, Word8# #)) -> Word -> Word -> (Word, Word)
+apply3 opToTest (W# a) (W# b) =
+    let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #)
+        (# ra, rb #) = opToTest sa sb
+    in (W# (extendWord8# ra), W# (extendWord8# rb))
+{-# NOINLINE apply3 #-}
+
+instance
+        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
+         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
+      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
+    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
+        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
+            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
+            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
+            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
+            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2
+
+instance
+        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
+         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
+      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
+    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
+        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
+        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
+        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
+        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
+        ")"
diff --git a/testsuite/tests/primops/should_run/ArithWord8.stdout b/testsuite/tests/primops/should_run/ArithWord8.stdout
new file mode 100644 (file)
index 0000000..b745ea0
--- /dev/null
@@ -0,0 +1,8 @@
+Pass: passing Word8# on the stack
+Pass: notWord8#
+Pass: plusWord8#
+Pass: subWord8#
+Pass: timesWord8#
+Pass: remWord8#
+Pass: quotWord8#
+Pass: quotRemWord8#
diff --git a/testsuite/tests/primops/should_run/CmpInt8.hs b/testsuite/tests/primops/should_run/CmpInt8.hs
new file mode 100644 (file)
index 0000000..daea227
--- /dev/null
@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Data.Int
+import Data.List
+import GHC.Prim
+import GHC.Exts
+
+
+-- Having a wrapper gives us two things:
+-- * it's easier to test everything (no need for code using raw primops)
+-- * we test the deriving mechanism for Int8#
+data TestInt8 = T8 Int8#
+    deriving (Eq, Ord)
+
+mkT8 :: Int -> TestInt8
+mkT8 (I# a) = T8 (narrowInt8# a)
+
+main :: IO ()
+main = do
+    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
+
+    --
+    -- (==)
+    --
+    let expected = [ a == b | (a, b) <- input ]
+        actual = [ mkT8 a == mkT8 b | (a, b) <- input ]
+    checkResults "(==)" input expected actual
+
+    --
+    -- (/=)
+    --
+    let expected = [ a /= b | (a, b) <- input ]
+        actual = [ mkT8 a /= mkT8 b | (a, b) <- input ]
+    checkResults "(/=)" input expected actual
+
+    --
+    -- (<)
+    --
+    let expected = [ a < b | (a, b) <- input ]
+        actual = [ mkT8 a < mkT8 b | (a, b) <- input ]
+    checkResults "(<)" input expected actual
+
+    --
+    -- (>)
+    --
+    let expected = [ a > b | (a, b) <- input ]
+        actual = [ mkT8 a > mkT8 b | (a, b) <- input ]
+    checkResults "(>)" input expected actual
+
+    --
+    -- (<=)
+    --
+    let expected = [ a <= b | (a, b) <- input ]
+        actual = [ mkT8 a <= mkT8 b | (a, b) <- input ]
+    checkResults "(<=)" input expected actual
+
+    --
+    -- (>=)
+    --
+    let expected = [ a >= b | (a, b) <- input ]
+        actual = [ mkT8 a >= mkT8 b | (a, b) <- input ]
+    checkResults "(>=)" input expected actual
+
+checkResults
+    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
+checkResults test inputs expected actual =
+    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
+        Nothing -> putStrLn $ "Pass: " ++ test
+        Just i -> error $
+            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
+              ++ " expected: " ++ show (expected !! i)
+              ++ " but got: " ++ show (actual !! i)
+
+allInt8 :: [Int]
+allInt8 = [ minInt8 .. maxInt8 ]
+
+minInt8 :: Int
+minInt8 = fromIntegral (minBound :: Int8)
+
+maxInt8 :: Int
+maxInt8 = fromIntegral (maxBound :: Int8)
diff --git a/testsuite/tests/primops/should_run/CmpInt8.stdout b/testsuite/tests/primops/should_run/CmpInt8.stdout
new file mode 100644 (file)
index 0000000..191d2b4
--- /dev/null
@@ -0,0 +1,6 @@
+Pass: (==)
+Pass: (/=)
+Pass: (<)
+Pass: (>)
+Pass: (<=)
+Pass: (>=)
diff --git a/testsuite/tests/primops/should_run/CmpWord8.hs b/testsuite/tests/primops/should_run/CmpWord8.hs
new file mode 100644 (file)
index 0000000..101f783
--- /dev/null
@@ -0,0 +1,84 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import Data.Word
+import Data.List
+import GHC.Prim
+import GHC.Exts
+
+
+-- Having a wrapper gives us two things:
+-- * it's easier to test everything (no need for code using raw primops)
+-- * we test the deriving mechanism for Word8#
+data TestWord8 = T8 Word8#
+    deriving (Eq, Ord)
+
+mkT8 :: Word -> TestWord8
+mkT8 (W# a) = T8 (narrowWord8# a)
+
+main :: IO ()
+main = do
+    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
+
+    --
+    -- (==)
+    --
+    let expected = [ a == b | (a, b) <- input ]
+        actual = [ mkT8 a == mkT8 b | (a, b) <- input ]
+    checkResults "(==)" input expected actual
+
+    --
+    -- (/=)
+    --
+    let expected = [ a /= b | (a, b) <- input ]
+        actual = [ mkT8 a /= mkT8 b | (a, b) <- input ]
+    checkResults "(/=)" input expected actual
+
+    --
+    -- (<)
+    --
+    let expected = [ a < b | (a, b) <- input ]
+        actual = [ mkT8 a < mkT8 b | (a, b) <- input ]
+    checkResults "(<)" input expected actual
+
+    --
+    -- (>)
+    --
+    let expected = [ a > b | (a, b) <- input ]
+        actual = [ mkT8 a > mkT8 b | (a, b) <- input ]
+    checkResults "(>)" input expected actual
+
+    --
+    -- (<=)
+    --
+    let expected = [ a <= b | (a, b) <- input ]
+        actual = [ mkT8 a <= mkT8 b | (a, b) <- input ]
+    checkResults "(<=)" input expected actual
+
+    --
+    -- (>=)
+    --
+    let expected = [ a >= b | (a, b) <- input ]
+        actual = [ mkT8 a >= mkT8 b | (a, b) <- input ]
+    checkResults "(>=)" input expected actual
+
+checkResults
+    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
+checkResults test inputs expected actual =
+    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
+        Nothing -> putStrLn $ "Pass: " ++ test
+        Just i -> error $
+            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
+              ++ " expected: " ++ show (expected !! i)
+              ++ " but got: " ++ show (actual !! i)
+
+allWord8 :: [Word]
+allWord8 = [ minWord8 .. maxWord8 ]
+
+minWord8 :: Word
+minWord8 = fromIntegral (minBound :: Word8)
+
+maxWord8 :: Word
+maxWord8 = fromIntegral (maxBound :: Word8)
diff --git a/testsuite/tests/primops/should_run/CmpWord8.stdout b/testsuite/tests/primops/should_run/CmpWord8.stdout
new file mode 100644 (file)
index 0000000..191d2b4
--- /dev/null
@@ -0,0 +1,6 @@
+Pass: (==)
+Pass: (/=)
+Pass: (<)
+Pass: (>)
+Pass: (<=)
+Pass: (>=)
diff --git a/testsuite/tests/primops/should_run/ShowPrim.hs b/testsuite/tests/primops/should_run/ShowPrim.hs
new file mode 100644 (file)
index 0000000..5670032
--- /dev/null
@@ -0,0 +1,14 @@
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+
+data Test = Test Int8# Word8#
+    deriving (Show)
+
+test1 :: Test
+test1 = Test (narrowInt8# 1#) (narrowWord8# 2##)
+
+main :: IO ()
+main = print test1
diff --git a/testsuite/tests/primops/should_run/ShowPrim.stdout b/testsuite/tests/primops/should_run/ShowPrim.stdout
new file mode 100644 (file)
index 0000000..5720eff
--- /dev/null
@@ -0,0 +1 @@
+Test (narrowInt8# 1#) (narrowWord8# 2##)
index 742206d..ecf995b 100644 (file)
@@ -17,3 +17,8 @@ test('T10678',
      compile_and_run, ['-O'])
 test('T11296', normal, compile_and_run, [''])
 test('T13825-compile', normal, compile_and_run, [''])
+test('ArithInt8', omit_ways(['ghci']), compile_and_run, [''])
+test('ArithWord8', omit_ways(['ghci']), compile_and_run, [''])
+test('CmpInt8', normal, compile_and_run, [''])
+test('CmpWord8', normal, compile_and_run, [''])
+test('ShowPrim', normal, compile_and_run, [''])
index e4779bf..e422c1f 100644 (file)
@@ -834,6 +834,8 @@ ppType (TyApp (TyCon "Any")         []) = "anyTy"
 ppType (TyApp (TyCon "Bool")        []) = "boolTy"
 
 ppType (TyApp (TyCon "Int#")        []) = "intPrimTy"
+ppType (TyApp (TyCon "Int8#")       []) = "int8PrimTy"
+ppType (TyApp (TyCon "Word8#")      []) = "word8PrimTy"
 ppType (TyApp (TyCon "Int32#")      []) = "int32PrimTy"
 ppType (TyApp (TyCon "Int64#")      []) = "int64PrimTy"
 ppType (TyApp (TyCon "Char#")       []) = "charPrimTy"