Add support for sized literals in the bytecode interpreter.

The bytecode interpreter only has branching instructions for
word-sized values. These are used for pattern matching.
Branching instructions for other types (e.g. Int16# or Word8#)
weren't needed, since unoptimized Core or STG never requires
branching on types like this.

It's now possible for optimized STG to reach the bytecode
generator (e.g. fat interface files or certain compiler flag
combinations), which requires dealing with various sized
literals in branches.

This patch improves support for generating bytecode from
optimized STG by adding the following new bytecode
instructions:

    TESTLT_I64
    TESTEQ_I64
    TESTLT_I32
    TESTEQ_I32
    TESTLT_I16
    TESTEQ_I16
    TESTLT_I8
    TESTEQ_I8
    TESTLT_W64
    TESTEQ_W64
    TESTLT_W32
    TESTEQ_W32
    TESTLT_W16
    TESTEQ_W16
    TESTLT_W8
    TESTEQ_W8

Fixes #21945

4 files changed, 162 insertions, 10 deletions

diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
index 9163aeacd4..24e2645052 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -440,6 +440,38 @@ assembleI platform i = case i of
                                  emit bci_TESTLT_W [Op np, LabelOp l]
   TESTEQ_W  w l            -> do np <- word w
                                  emit bci_TESTEQ_W [Op np, LabelOp l]
+  TESTLT_I64  i l          -> do np <- int64 i
+                                 emit bci_TESTLT_I64 [Op np, LabelOp l]
+  TESTEQ_I64  i l          -> do np <- int64 i
+                                 emit bci_TESTEQ_I64 [Op np, LabelOp l]
+  TESTLT_I32  i l          -> do np <- int (fromIntegral i)
+                                 emit bci_TESTLT_I32 [Op np, LabelOp l]
+  TESTEQ_I32 i l           -> do np <- int (fromIntegral i)
+                                 emit bci_TESTEQ_I32 [Op np, LabelOp l]
+  TESTLT_I16  i l          -> do np <- int (fromIntegral i)
+                                 emit bci_TESTLT_I16 [Op np, LabelOp l]
+  TESTEQ_I16 i l           -> do np <- int (fromIntegral i)
+                                 emit bci_TESTEQ_I16 [Op np, LabelOp l]
+  TESTLT_I8  i l           -> do np <- int (fromIntegral i)
+                                 emit bci_TESTLT_I8 [Op np, LabelOp l]
+  TESTEQ_I8 i l            -> do np <- int (fromIntegral i)
+                                 emit bci_TESTEQ_I8 [Op np, LabelOp l]
+  TESTLT_W64  w l          -> do np <- word64 w
+                                 emit bci_TESTLT_W64 [Op np, LabelOp l]
+  TESTEQ_W64  w l          -> do np <- word64 w
+                                 emit bci_TESTEQ_W64 [Op np, LabelOp l]
+  TESTLT_W32  w l          -> do np <- word (fromIntegral w)
+                                 emit bci_TESTLT_W32 [Op np, LabelOp l]
+  TESTEQ_W32  w l          -> do np <- word (fromIntegral w)
+                                 emit bci_TESTEQ_W32 [Op np, LabelOp l]
+  TESTLT_W16  w l          -> do np <- word (fromIntegral w)
+                                 emit bci_TESTLT_W16 [Op np, LabelOp l]
+  TESTEQ_W16  w l          -> do np <- word (fromIntegral w)
+                                 emit bci_TESTEQ_W16 [Op np, LabelOp l]
+  TESTLT_W8  w l           -> do np <- word (fromIntegral w)
+                                 emit bci_TESTLT_W8 [Op np, LabelOp l]
+  TESTEQ_W8  w l           -> do np <- word (fromIntegral w)
+                                 emit bci_TESTEQ_W8 [Op np, LabelOp l]
   TESTLT_F  f l            -> do np <- float f
                                  emit bci_TESTLT_F [Op np, LabelOp l]
   TESTEQ_F  f l            -> do np <- float f
@@ -505,6 +537,7 @@ assembleI platform i = case i of
     int16 = words . mkLitI64 platform
     int32 = words . mkLitI64 platform
     int64 = words . mkLitI64 platform
+    word64 = words . mkLitW64 platform
     words ws = lit (map BCONPtrWord ws)
     word w = words [w]
 
@@ -590,6 +623,7 @@ mkLitI   ::             Int    -> [Word]
 mkLitF   :: Platform -> Float  -> [Word]
 mkLitD   :: Platform -> Double -> [Word]
 mkLitI64 :: Platform -> Int64  -> [Word]
+mkLitW64 :: Platform -> Word64 -> [Word]
 
 mkLitF platform f = case platformWordSize platform of
   PW4 -> runST $ do
@@ -636,13 +670,18 @@ mkLitI64 platform ii = case platformWordSize platform of
         w1 <- readArray d_arr 1
         return [w0 :: Word,w1]
      )
-   PW8 -> runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 ii
+   PW8 -> [fromIntegral ii :: Word]
+
+mkLitW64 platform ww = case platformWordSize platform of
+   PW4 -> runST (do
+        arr <- newArray_ ((0::Word),1)
+        writeArray arr 0 ww
         d_arr <- castSTUArray arr
         w0 <- readArray d_arr 0
-        return [w0 :: Word]
+        w1 <- readArray d_arr 1
+        return [w0 :: Word,w1]
      )
+   PW8 -> [fromIntegral ww :: Word]
 
 mkLitI i = [fromIntegral i :: Word]
 
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
index e5cd896c1c..498152c471 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -24,7 +24,9 @@ import GHC.Core.DataCon
 import GHC.Builtin.PrimOps
 import GHC.Runtime.Heap.Layout
 
+import Data.Int
 import Data.Word
+
 import GHC.Stack.CCS (CostCentre)
 
 import GHC.Stg.Syntax
@@ -141,6 +143,22 @@ data BCInstr
    | TESTEQ_I  Int    LocalLabel
    | TESTLT_W  Word   LocalLabel
    | TESTEQ_W  Word   LocalLabel
+   | TESTLT_I64 Int64 LocalLabel
+   | TESTEQ_I64 Int64 LocalLabel
+   | TESTLT_I32 Int32 LocalLabel
+   | TESTEQ_I32 Int32 LocalLabel
+   | TESTLT_I16 Int16 LocalLabel
+   | TESTEQ_I16 Int16 LocalLabel
+   | TESTLT_I8 Int8   LocalLabel
+   | TESTEQ_I8 Int16  LocalLabel
+   | TESTLT_W64 Word64 LocalLabel
+   | TESTEQ_W64 Word64 LocalLabel
+   | TESTLT_W32 Word32 LocalLabel
+   | TESTEQ_W32 Word32 LocalLabel
+   | TESTLT_W16 Word16 LocalLabel
+   | TESTEQ_W16 Word16 LocalLabel
+   | TESTLT_W8 Word8 LocalLabel
+   | TESTEQ_W8 Word8 LocalLabel
    | TESTLT_F  Float  LocalLabel
    | TESTEQ_F  Float  LocalLabel
    | TESTLT_D  Double LocalLabel
@@ -291,6 +309,22 @@ instance Outputable BCInstr where
    ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
    ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
    ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTLT_I64  i lab)   = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I64  i lab)   = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_I32  i lab)   = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I32  i lab)   = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_I16  i lab)   = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I16  i lab)   = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_I8  i lab)    = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I8  i lab)    = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_W64  i lab)   = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_W64  i lab)   = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_W32  i lab)   = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_W32  i lab)   = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_W16  i lab)   = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_W16  i lab)   = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTLT_W8  i lab)    = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_W8  i lab)    = text "TESTEQ_W8" <+> ppr i <+> text "__" <> ppr lab
    ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
    ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
@@ -380,6 +414,22 @@ bciStackUse TESTLT_I{}            = 0
 bciStackUse TESTEQ_I{}            = 0
 bciStackUse TESTLT_W{}            = 0
 bciStackUse TESTEQ_W{}            = 0
+bciStackUse TESTLT_I64{}          = 0
+bciStackUse TESTEQ_I64{}          = 0
+bciStackUse TESTLT_I32{}          = 0
+bciStackUse TESTEQ_I32{}          = 0
+bciStackUse TESTLT_I16{}          = 0
+bciStackUse TESTEQ_I16{}          = 0
+bciStackUse TESTLT_I8{}           = 0
+bciStackUse TESTEQ_I8{}           = 0
+bciStackUse TESTLT_W64{}          = 0
+bciStackUse TESTEQ_W64{}          = 0
+bciStackUse TESTLT_W32{}          = 0
+bciStackUse TESTEQ_W32{}          = 0
+bciStackUse TESTLT_W16{}          = 0
+bciStackUse TESTEQ_W16{}          = 0
+bciStackUse TESTLT_W8{}           = 0
+bciStackUse TESTEQ_W8{}           = 0
 bciStackUse TESTLT_F{}            = 0
 bciStackUse TESTEQ_F{}            = 0
 bciStackUse TESTLT_D{}            = 0
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index 7cf5f477b7..b59cbfe779 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -936,12 +936,26 @@ doCase d s p scrut bndr alts
               | otherwise
               -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
             LitAlt l -> case l of
-              LitNumber LitNumInt i  -> DiscrI (fromInteger i)
-              LitNumber LitNumWord w -> DiscrW (fromInteger w)
-              LitFloat r             -> DiscrF (fromRational r)
-              LitDouble r            -> DiscrD (fromRational r)
-              LitChar i              -> DiscrI (ord i)
-              _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)
+              LitNumber LitNumInt i    -> DiscrI (fromInteger i)
+              LitNumber LitNumInt8 i   -> DiscrI8 (fromInteger i)
+              LitNumber LitNumInt16 i  -> DiscrI16 (fromInteger i)
+              LitNumber LitNumInt32 i  -> DiscrI32 (fromInteger i)
+              LitNumber LitNumInt64 i  -> DiscrI64 (fromInteger i)
+              LitNumber LitNumWord w   -> DiscrW (fromInteger w)
+              LitNumber LitNumWord8 w  -> DiscrW8 (fromInteger w)
+              LitNumber LitNumWord16 w -> DiscrW16 (fromInteger w)
+              LitNumber LitNumWord32 w -> DiscrW32 (fromInteger w)
+              LitNumber LitNumWord64 w -> DiscrW64 (fromInteger w)
+              LitNumber LitNumBigNat _ -> unsupported
+              LitFloat r               -> DiscrF (fromRational r)
+              LitDouble r              -> DiscrD (fromRational r)
+              LitChar i                -> DiscrI (ord i)
+              LitString {}             -> unsupported
+              LitRubbish {}            -> unsupported
+              LitNullAddr {}           -> unsupported
+              LitLabel {}              -> unsupported
+              where
+                  unsupported = pprPanic "schemeE(StgCase).my_discr:" (ppr l)
 
         maybe_ncons
            | not isAlgCase = Nothing
@@ -1841,14 +1855,30 @@ mkMultiBranch maybe_ncons raw_ways = do
          notd_ways = sortBy (comparing fst) not_defaults
 
          testLT (DiscrI i) fail_label = TESTLT_I i fail_label
+         testLT (DiscrI8 i) fail_label = TESTLT_I8 (fromIntegral i) fail_label
+         testLT (DiscrI16 i) fail_label = TESTLT_I16 (fromIntegral i) fail_label
+         testLT (DiscrI32 i) fail_label = TESTLT_I32 (fromIntegral i) fail_label
+         testLT (DiscrI64 i) fail_label = TESTLT_I64 (fromIntegral i) fail_label
          testLT (DiscrW i) fail_label = TESTLT_W i fail_label
+         testLT (DiscrW8 i) fail_label = TESTLT_W8 (fromIntegral i) fail_label
+         testLT (DiscrW16 i) fail_label = TESTLT_W16 (fromIntegral i) fail_label
+         testLT (DiscrW32 i) fail_label = TESTLT_W32 (fromIntegral i) fail_label
+         testLT (DiscrW64 i) fail_label = TESTLT_W64 (fromIntegral i) fail_label
          testLT (DiscrF i) fail_label = TESTLT_F i fail_label
          testLT (DiscrD i) fail_label = TESTLT_D i fail_label
          testLT (DiscrP i) fail_label = TESTLT_P i fail_label
          testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"
 
          testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label
+         testEQ (DiscrI8 i) fail_label = TESTEQ_I8 (fromIntegral i) fail_label
+         testEQ (DiscrI16 i) fail_label = TESTEQ_I16 (fromIntegral i) fail_label
+         testEQ (DiscrI32 i) fail_label = TESTEQ_I32 (fromIntegral i) fail_label
+         testEQ (DiscrI64 i) fail_label = TESTEQ_I64 (fromIntegral i) fail_label
          testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label
+         testEQ (DiscrW8 i) fail_label = TESTEQ_W8 (fromIntegral i) fail_label
+         testEQ (DiscrW16 i) fail_label = TESTEQ_W16 (fromIntegral i) fail_label
+         testEQ (DiscrW32 i) fail_label = TESTEQ_W32 (fromIntegral i) fail_label
+         testEQ (DiscrW64 i) fail_label = TESTEQ_W64 (fromIntegral i) fail_label
          testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label
          testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label
          testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label
@@ -1859,7 +1889,15 @@ mkMultiBranch maybe_ncons raw_ways = do
             [] -> panic "mkMultiBranch: awesome foursome"
             (discr, _):_ -> case discr of
                 DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )
+                DiscrI8 _ -> ( DiscrI8 minBound, DiscrI8 maxBound )
+                DiscrI16 _ -> ( DiscrI16 minBound, DiscrI16 maxBound )
+                DiscrI32 _ -> ( DiscrI32 minBound, DiscrI32 maxBound )
+                DiscrI64 _ -> ( DiscrI64 minBound, DiscrI64 maxBound )
                 DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )
+                DiscrW8 _ -> ( DiscrW8 minBound, DiscrW8 maxBound )
+                DiscrW16 _ -> ( DiscrW16 minBound, DiscrW16 maxBound )
+                DiscrW32 _ -> ( DiscrW32 minBound, DiscrW32 maxBound )
+                DiscrW64 _ -> ( DiscrW64 minBound, DiscrW64 maxBound )
                 DiscrF _ -> ( DiscrF minF,      DiscrF maxF )
                 DiscrD _ -> ( DiscrD minD,      DiscrD maxD )
                 DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )
@@ -1895,7 +1933,15 @@ mkMultiBranch maybe_ncons raw_ways = do
 -- Describes case alts
 data Discr
    = DiscrI Int
+   | DiscrI8 Int8
+   | DiscrI16 Int16
+   | DiscrI32 Int32
+   | DiscrI64 Int64
    | DiscrW Word
+   | DiscrW8 Word8
+   | DiscrW16 Word16
+   | DiscrW32 Word32
+   | DiscrW64 Word64
    | DiscrF Float
    | DiscrD Double
    | DiscrP Word16
@@ -1904,7 +1950,15 @@ data Discr
 
 instance Outputable Discr where
    ppr (DiscrI i) = int i
+   ppr (DiscrI8 i) = text (show i)
+   ppr (DiscrI16 i) = text (show i)
+   ppr (DiscrI32 i) = text (show i)
+   ppr (DiscrI64 i) = text (show i)
    ppr (DiscrW w) = text (show w)
+   ppr (DiscrW8 w) = text (show w)
+   ppr (DiscrW16 w) = text (show w)
+   ppr (DiscrW32 w) = text (show w)
+   ppr (DiscrW64 w) = text (show w)
    ppr (DiscrF f) = text (show f)
    ppr (DiscrD d) = text (show d)
    ppr (DiscrP i) = ppr i
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 0107f6fc6a..b4a21a314e 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -896,6 +896,12 @@ instance Outputable Ordering where
     ppr EQ = text "EQ"
     ppr GT = text "GT"
 
+instance Outputable Int8 where
+   ppr n = integer $ fromIntegral n
+
+instance Outputable Int16 where
+   ppr n = integer $ fromIntegral n
+
 instance Outputable Int32 where
    ppr n = integer $ fromIntegral n
 
@@ -908,6 +914,9 @@ instance Outputable Int where
 instance Outputable Integer where
     ppr n = integer n
 
+instance Outputable Word8 where
+    ppr n = integer $ fromIntegral n
+
 instance Outputable Word16 where
     ppr n = integer $ fromIntegral n