compiler/GHC/Builtin/Names.hs

@@ -336,7 +336,7 @@ basicKnownKeyNames
         -- FFI primitive types that are not wired-in.
         stablePtrTyConName, ptrTyConName, funPtrTyConName,
         int8TyConName, int16TyConName, int32TyConName, int64TyConName,
-        word16TyConName, word32TyConName, word64TyConName,
+        word8TyConName, word16TyConName, word32TyConName, word64TyConName,
 
         -- Others
         otherwiseIdName, inlineIdName,
@@ -1463,7 +1463,8 @@ int32TyConName    = tcQual gHC_INT  (fsLit "Int32") int32TyConKey
 int64TyConName    = tcQual gHC_INT  (fsLit "Int64") int64TyConKey
 
 -- Word module
-word16TyConName, word32TyConName, word64TyConName :: Name
+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name
+word8TyConName    = tcQual  gHC_WORD (fsLit "Word8")  word8TyConKey
 word16TyConName   = tcQual  gHC_WORD (fsLit "Word16") word16TyConKey
 word32TyConName   = tcQual  gHC_WORD (fsLit "Word32") word32TyConKey
 word64TyConName   = tcQual  gHC_WORD (fsLit "Word64") word64TyConKey

compiler/GHC/Builtin/Types.hs

@@ -55,7 +55,7 @@ module GHC.Builtin.Types (
         wordTyCon, wordDataCon, wordTyConName, wordTy,
 
         -- * Word8
-        word8TyCon, word8DataCon, word8TyConName, word8Ty,
+        word8TyCon, word8DataCon, word8Ty,
 
         -- * List
         listTyCon, listTyCon_RDR, listTyConName, listTyConKey,
@@ -251,7 +251,6 @@ wiredInTyCons = [ -- Units are not treated like other tuples, because they
                 , floatTyCon
                 , intTyCon
                 , wordTyCon
-                , word8TyCon
                 , listTyCon
                 , orderingTyCon
                 , maybeTyCon
@@ -354,10 +353,9 @@ nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
 justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
                                           justDataConKey justDataCon
 
-wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
+wordTyConName, wordDataConName, word8DataConName :: Name
 wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon
 wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon
-word8TyConName     = mkWiredInTyConName   UserSyntax gHC_WORD  (fsLit "Word8")  word8TyConKey    word8TyCon
 word8DataConName   = mkWiredInDataConName UserSyntax gHC_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon
 
 floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name
@@ -1641,7 +1639,7 @@ word8TyCon = pcTyCon word8TyConName
                             (NoSourceText, fsLit "HsWord8"))) []
                      [word8DataCon]
 word8DataCon :: DataCon
-word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon
+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon
 
 floatTy :: Type
 floatTy = mkTyConTy floatTyCon

compiler/GHC/Builtin/primops.txt.pp

@@ -291,8 +291,8 @@ section "Int8#"
 
 primtype Int8#
 
-primop Int8Extend "extendInt8#" GenPrimOp Int8# -> Int#
-primop Int8Narrow "narrowInt8#" GenPrimOp Int# -> Int8#
+primop Int8ExtendOp "extendInt8#" GenPrimOp Int8# -> Int#
+primop Int8NarrowOp "narrowInt8#" GenPrimOp Int# -> Int8#
 
 primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#
 
@@ -332,8 +332,8 @@ section "Word8#"
 
 primtype Word8#
 
-primop Word8Extend "extendWord8#" GenPrimOp Word8# -> Word#
-primop Word8Narrow "narrowWord8#" GenPrimOp Word# -> Word8#
+primop Word8ExtendOp "extendWord8#" GenPrimOp Word8# -> Word#
+primop Word8NarrowOp "narrowWord8#" GenPrimOp Word# -> Word8#
 
 primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#
 
@@ -373,8 +373,8 @@ section "Int16#"
 
 primtype Int16#
 
-primop Int16Extend "extendInt16#" GenPrimOp Int16# -> Int#
-primop Int16Narrow "narrowInt16#" GenPrimOp Int# -> Int16#
+primop Int16ExtendOp "extendInt16#" GenPrimOp Int16# -> Int#
+primop Int16NarrowOp "narrowInt16#" GenPrimOp Int# -> Int16#
 
 primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#
 
@@ -414,8 +414,8 @@ section "Word16#"
 
 primtype Word16#
 
-primop Word16Extend "extendWord16#" GenPrimOp Word16# -> Word#
-primop Word16Narrow "narrowWord16#" GenPrimOp Word# -> Word16#
+primop Word16ExtendOp "extendWord16#" GenPrimOp Word16# -> Word#
+primop Word16NarrowOp "narrowWord16#" GenPrimOp Word# -> Word16#
 
 primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#
 
@@ -448,6 +448,26 @@ primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int#
 primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int#
 primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int#
 
+------------------------------------------------------------------------
+section "Int32#"
+        {Operations on 32-bit integers.}
+------------------------------------------------------------------------
+
+primtype Int32#
+
+primop Int32ExtendOp "extendInt32#" GenPrimOp Int32# -> Int#
+primop Int32NarrowOp "narrowInt32#" GenPrimOp Int# -> Int32#
+
+------------------------------------------------------------------------
+section "Word32#"
+        {Operations on 32-bit unsigned integers.}
+------------------------------------------------------------------------
+
+primtype Word32#
+
+primop Word32ExtendOp "extendWord32#" GenPrimOp Word32# -> Word#
+primop Word32NarrowOp "narrowWord32#" GenPrimOp Word# -> Word32#
+
 #if WORD_SIZE_IN_BITS < 64
 ------------------------------------------------------------------------
 section "Int64#"

compiler/GHC/ByteCode/Asm.hs

@@ -464,6 +464,12 @@ assembleI platform i = case i of
     literal (LitNumber nt i) = case nt of
       LitNumInt     -> int (fromIntegral i)
       LitNumWord    -> int (fromIntegral i)
+      LitNumInt8    -> int8 (fromIntegral i)
+      LitNumWord8   -> int8 (fromIntegral i)
+      LitNumInt16   -> int16 (fromIntegral i)
+      LitNumWord16  -> int16 (fromIntegral i)
+      LitNumInt32   -> int32 (fromIntegral i)
+      LitNumWord32  -> int32 (fromIntegral i)
       LitNumInt64   -> int64 (fromIntegral i)
       LitNumWord64  -> int64 (fromIntegral i)
       LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"
@@ -478,6 +484,9 @@ assembleI platform i = case i of
     float = words . mkLitF
     double = words . mkLitD platform
     int = words . mkLitI
+    int8 = words . mkLitI64 platform
+    int16 = words . mkLitI64 platform
+    int32 = words . mkLitI64 platform
     int64 = words . mkLitI64 platform
     words ws = lit (map BCONPtrWord ws)
     word w = words [w]

compiler/GHC/ByteCode/Types.hs

@@ -37,7 +37,7 @@ import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Maybe (catMaybes)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
 import GHC.Stack.CCS
 
 -- -----------------------------------------------------------------------------
@@ -72,7 +72,7 @@ type ItblEnv = NameEnv (Name, ItblPtr)
         -- We need the Name in the range so we know which
         -- elements to filter out when unloading a module
 
-newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
+newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)
   deriving (Show, NFData)
 
 data UnlinkedBCO

compiler/GHC/Cmm.hs

@@ -228,6 +228,12 @@ data CmmStatic
   | CmmFileEmbed FilePath
         -- ^ an embedded binary file
 
+instance Outputable CmmStatic where
+  ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit
+  ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n
+  ppr (CmmString _) = text "CmmString"
+  ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp
+
 -- Static data before SRT generation
 data GenCmmStatics (rawOnly :: Bool) where
     CmmStatics

compiler/GHC/Cmm/Expr.hs

@@ -39,6 +39,7 @@ import GHC.Cmm.CLabel
 import GHC.Cmm.MachOp
 import GHC.Cmm.Type
 import GHC.Utils.Panic (panic)
+import GHC.Utils.Outputable
 import GHC.Types.Unique
 
 import Data.Set (Set)
@@ -210,6 +211,16 @@ data CmmLit
                      -- of bytes used
   deriving Eq
 
+instance Outputable CmmLit where
+  ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w
+  ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w
+  ppr (CmmVec xs) = text "CmmVec" <+> ppr xs
+  ppr (CmmLabel _) = text "CmmLabel"
+  ppr (CmmLabelOff _ _) = text "CmmLabelOff"
+  ppr (CmmLabelDiffOff _ _ _ _) = text "CmmLabelDiffOff"
+  ppr (CmmBlock blk) = text "CmmBlock" <+> ppr blk
+  ppr CmmHighStackMark = text "CmmHighStackMark"
+
 cmmExprType :: Platform -> CmmExpr -> CmmType
 cmmExprType platform = \case
    (CmmLit lit)        -> cmmLitType platform lit

compiler/GHC/CmmToAsm/Ppr.hs

-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP, MagicHash #-}
 
 -----------------------------------------------------------------------------
 --
@@ -38,9 +38,17 @@ import Data.Word
 import Data.Bits
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
-import GHC.Exts
+import GHC.Exts hiding (extendWord8#)
 import GHC.Word
 
+#if MIN_VERSION_base(4,16,0)
+import GHC.Base (extendWord8#)
+#else
+extendWord8# :: Word# -> Word#
+extendWord8# w = w
+{-# INLINE extendWord8# #-}
+#endif
+
 -- -----------------------------------------------------------------------------
 -- Converting floating-point literals to integrals for printing
 
@@ -103,7 +111,7 @@ pprASCII str
        -- we know that the Chars we create are in the ASCII range
        -- so we bypass the check in "chr"
        chr' :: Word8 -> Char
-       chr' (W8# w#) = C# (chr# (word2Int# w#))
+       chr' (W8# w#) = C# (chr# (word2Int# (extendWord8# w#)))
 
        octal :: Word8 -> String
        octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)

compiler/GHC/CmmToC.hs

@@ -159,8 +159,14 @@ pprWordArray platform is_ro lbl ds
          -- See Note [StgWord alignment]
          , pprAlignment (wordWidth platform)
          , text "= {" ]
-    $$ nest 8 (commafy (pprStatics platform ds))
+    $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds))
     $$ text "};"
+  where
+    toLits :: [CmmStatic] -> [CmmLit]
+    toLits = map f
+      where
+        f (CmmStaticLit lit) = lit
+        f static             = pprPanic "pprWordArray: Unexpected literal"  (pprStatic platform static)
 
 pprAlignment :: Width -> SDoc
 pprAlignment words =
@@ -501,59 +507,69 @@ pprLit1 platform lit = case lit of
 -- ---------------------------------------------------------------------------
 -- Static data
 
-pprStatics :: Platform -> [CmmStatic] -> [SDoc]
-pprStatics platform = pprStatics'
+-- | Produce a list of word sized literals encoding the given list of 'CmmLit's.
+staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]
+staticLitsToWords platform = go . foldMap decomposeMultiWord
   where
-    pprStatics' = \case
-      [] -> []
-      (CmmStaticLit (CmmFloat f W32) : rest)
-        -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
-        | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
-        -> pprLit1 platform (floatToWord platform f) : pprStatics' rest'
-        -- adjacent floats aren't padded but combined into a single word
-        | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest
-        -> pprLit1 platform (floatPairToWord platform f g) : pprStatics' rest'
-        | wordWidth platform == W32
-        -> pprLit1 platform (floatToWord platform f) : pprStatics' rest
-        | otherwise
-        -> pprPanic "pprStatics: float" (vcat (map ppr' rest))
-          where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)
-                ppr' _other           = text "bad static!"
-
-      (CmmStaticLit (CmmFloat f W64) : rest)
-        -> map (pprLit1 platform) (doubleToWords platform f) ++ pprStatics' rest
-
-      (CmmStaticLit (CmmInt i W64) : rest)
-        | wordWidth platform == W32
-        -> case platformByteOrder platform of
-            BigEndian    -> pprStatics' (CmmStaticLit (CmmInt q W32) :
-                                         CmmStaticLit (CmmInt r W32) : rest)
-            LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) :
-                                         CmmStaticLit (CmmInt q W32) : rest)
-           where r = i .&. 0xffffffff
-                 q = i `shiftR` 32
-
-      (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)
-        | wordWidth platform == W64
-        -> case platformByteOrder platform of
-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)
-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)
-
-      (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)
-        | wordWidth platform == W32
-        -> case platformByteOrder platform of
-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)
-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)
-
-      (CmmStaticLit (CmmInt _ w) : _)
-        | w /= wordWidth platform
-        -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
-
-      (CmmStaticLit lit : rest)
-        -> pprLit1 platform lit : pprStatics' rest
-
-      (other : _)
-        -> pprPanic "pprStatics: other" (pprStatic platform other)
+    -- rem_bytes is how many bytes remain in the word we are currently filling.
+    -- accum is the word we are filling.
+    go :: [CmmLit] -> [SDoc]
+    go [] = []
+    go lits@(lit : _)
+      | Just _ <- isSubWordLit lit
+      = goSubWord wordWidthBytes 0 lits
+    go (lit : rest)
+      = pprLit1 platform lit : go rest
+
+    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]
+    goSubWord rem_bytes accum (lit : rest)
+      | Just (bytes, w) <- isSubWordLit lit
+      , rem_bytes >= widthInBytes w
+      = let accum' =
+              case platformByteOrder platform of
+                BigEndian    -> (accum `shiftL` widthInBits w) .|. bytes
+                LittleEndian -> (accum `shiftL` widthInBits w) .|. byteSwap w bytes
+        in goSubWord (rem_bytes - widthInBytes w) accum' rest
+    goSubWord rem_bytes accum rest
+      = pprWord (byteSwap (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest
+
+    -- Decompose multi-word or floating-point literals into multiple
+    -- single-word (or smaller) literals.
+    decomposeMultiWord :: CmmLit -> [CmmLit]
+    decomposeMultiWord (CmmFloat n W64)
+      -- This will produce a W64 integer, which will then be broken up further
+      -- on the next iteration on 32-bit platforms.
+      = [doubleToWord64 n]
+    decomposeMultiWord (CmmFloat n W32)
+      = [floatToWord32 n]
+    decomposeMultiWord (CmmInt n W64)
+      | W32 <- wordWidth platform
+      = [CmmInt hi W32, CmmInt lo W32]
+      where
+        hi = n `shiftR` 32
+        lo = n .&. 0xffffffff
+    decomposeMultiWord lit = [lit]
+
+    -- Decompose a sub-word-sized literal into the integer value and its
+    -- (sub-word-sized) width.
+    isSubWordLit :: CmmLit -> Maybe (Integer, Width)
+    isSubWordLit lit =
+      case lit of
+        CmmInt n w
+          | w < wordWidth platform   -> Just (n, w)
+        _                            -> Nothing
+
+    wordWidthBytes = widthInBytes $ wordWidth platform
+
+    pprWord :: Integer -> SDoc
+    pprWord n = pprHexVal platform n (wordWidth platform)
+
+byteSwap :: Width -> Integer -> Integer
+byteSwap width n = foldl' f 0 bytes
+  where
+    f acc m = (acc `shiftL` 8) .|. m
+    bytes = [ byte i | i <- [0..widthInBytes width - 1] ]
+    byte i = (n `shiftR` (i*8)) .&. 0xff
 
 pprStatic :: Platform -> CmmStatic -> SDoc
 pprStatic platform s = case s of
@@ -1252,69 +1268,30 @@ pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))
 -- This is a hack to turn the floating point numbers into ints that we
 -- can safely initialise to static locations.
 
-castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
-castFloatToWord32Array = U.castSTUArray
-
-castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
-castDoubleToWord64Array = U.castSTUArray
-
-floatToWord :: Platform -> Rational -> CmmLit
-floatToWord platform r
-  = runST (do
+floatToWord32 :: Rational -> CmmLit
+floatToWord32 r
+  = runST $ do
         arr <- newArray_ ((0::Int),0)
         writeArray arr 0 (fromRational r)
         arr' <- castFloatToWord32Array arr
         w32 <- readArray arr' 0
-        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))
-    )
-    where wo | wordWidth platform == W64
-             , BigEndian <- platformByteOrder platform
-             = 32
-             | otherwise
-             = 0
-
-floatPairToWord :: Platform -> Rational -> Rational -> CmmLit
-floatPairToWord platform r1 r2
-  = runST (do
-        arr <- newArray_ ((0::Int),1)
-        writeArray arr 0 (fromRational r1)
-        writeArray arr 1 (fromRational r2)
-        arr' <- castFloatToWord32Array arr
-        w32_1 <- readArray arr' 0
-        w32_2 <- readArray arr' 1
-        return (pprWord32Pair w32_1 w32_2)
-    )
-    where pprWord32Pair w32_1 w32_2
-              | BigEndian <- platformByteOrder platform =
-                  CmmInt ((shiftL i1 32) .|. i2) W64
-              | otherwise =
-                  CmmInt ((shiftL i2 32) .|. i1) W64
-              where i1 = toInteger w32_1
-                    i2 = toInteger w32_2
-
-doubleToWords :: Platform -> Rational -> [CmmLit]
-doubleToWords platform r
-  = runST (do
+        return (CmmInt (toInteger w32) W32)
+  where
+    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
+    castFloatToWord32Array = U.castSTUArray
+
+doubleToWord64 :: Rational -> CmmLit
+doubleToWord64 r
+  = runST $ do
         arr <- newArray_ ((0::Int),1)
         writeArray arr 0 (fromRational r)
         arr' <- castDoubleToWord64Array arr
         w64 <- readArray arr' 0
-        return (pprWord64 w64)
-    )
-    where targetWidth = wordWidth platform
-          pprWord64 w64
-              | targetWidth == W64 =
-                  [ CmmInt (toInteger w64) targetWidth ]
-              | targetWidth == W32 =
-                  [ CmmInt (toInteger targetW1) targetWidth
-                  , CmmInt (toInteger targetW2) targetWidth
-                  ]
-              | otherwise = panic "doubleToWords.pprWord64"
-              where (targetW1, targetW2) = case platformByteOrder platform of
-                        BigEndian    -> (wHi, wLo)
-                        LittleEndian -> (wLo, wHi)
-                    wHi = w64 `shiftR` 32
-                    wLo = w64 .&. 0xFFFFffff
+        return $ CmmInt (toInteger w64) W64
+  where
+    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
+    castDoubleToWord64Array = U.castSTUArray
+
 
 -- ---------------------------------------------------------------------------
 -- Utils

compiler/GHC/Core.hs

@@ -29,6 +29,7 @@ module GHC.Core (
 
         mkIntLit, mkIntLitWrap,
         mkWordLit, mkWordLitWrap,
+        mkWord8Lit,
         mkWord64LitWord64, mkInt64LitInt64,
         mkCharLit, mkStringLit,
         mkFloatLit, mkFloatLitFloat,
@@ -1997,6 +1998,9 @@ mkWordLit platform w = Lit (mkLitWord platform w)
 mkWordLitWrap :: Platform -> Integer -> Expr b
 mkWordLitWrap platform w = Lit (mkLitWordWrap platform w)
 
+mkWord8Lit :: Integer -> Expr b
+mkWord8Lit    w = Lit (mkLitWord8 w)
+
 mkWord64LitWord64 :: Word64 -> Expr b
 mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
 

compiler/GHC/Core/Opt/ConstantFold.hs

@@ -198,6 +198,46 @@ primOpRules nm = \case
    SrlOp       -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ]
 
    -- coercions
+
+   Int8ExtendOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+   Int16ExtendOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+   Int32ExtendOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]
+   Int8NarrowOp   -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit
+                                       , subsumedByPrimOp Int8NarrowOp
+                                       , narrowSubsumesAnd AndIOp Int8NarrowOp 8 ]
+   Int16NarrowOp  -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit
+                                       , subsumedByPrimOp Int8NarrowOp
+                                       , subsumedByPrimOp Int16NarrowOp
+                                       , narrowSubsumesAnd AndIOp Int16NarrowOp 16 ]
+   Int32NarrowOp  -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit
+                                       , subsumedByPrimOp Int8NarrowOp
+                                       , subsumedByPrimOp Int16NarrowOp
+                                       , subsumedByPrimOp Int32NarrowOp
+                                       , narrowSubsumesAnd AndIOp Int32NarrowOp 32 ]
+
+   Word8ExtendOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+                                       , extendNarrowPassthrough Word8NarrowOp 0xFF
+                                       ]
+   Word16ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+                                       , extendNarrowPassthrough Word16NarrowOp 0xFFFF
+                                       ]
+   Word32ExtendOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit
+                                       , extendNarrowPassthrough Word32NarrowOp 0xFFFFFFFF
+                                       ]
+   Word8NarrowOp  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit
+                                       , subsumedByPrimOp Word8NarrowOp
+                                       , narrowSubsumesAnd AndOp Word8NarrowOp 8 ]
+   Word16NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit
+                                       , subsumedByPrimOp Word8NarrowOp
+                                       , subsumedByPrimOp Word16NarrowOp
+                                       , narrowSubsumesAnd AndOp Word16NarrowOp 16 ]
+   Word32NarrowOp -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit
+                                       , subsumedByPrimOp Word8NarrowOp
+                                       , subsumedByPrimOp Word16NarrowOp
+                                       , subsumedByPrimOp Word32NarrowOp
+                                       , narrowSubsumesAnd AndOp Word32NarrowOp 32 ]
+
+
    WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform wordToIntLit
                                        , inversePrimOp IntToWordOp ]
    IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform intToWordLit
@@ -625,8 +665,14 @@ isMinBound :: Platform -> Literal -> Bool
 isMinBound _        (LitChar c)        = c == minBound
 isMinBound platform (LitNumber nt i)   = case nt of
    LitNumInt     -> i == platformMinInt platform
+   LitNumInt8    -> i == toInteger (minBound :: Int8)
+   LitNumInt16   -> i == toInteger (minBound :: Int16)
+   LitNumInt32   -> i == toInteger (minBound :: Int32)
    LitNumInt64   -> i == toInteger (minBound :: Int64)
    LitNumWord    -> i == 0
+   LitNumWord8   -> i == 0
+   LitNumWord16  -> i == 0
+   LitNumWord32  -> i == 0
    LitNumWord64  -> i == 0
    LitNumNatural -> i == 0
    LitNumInteger -> False
@@ -636,8 +682,14 @@ isMaxBound :: Platform -> Literal -> Bool
 isMaxBound _        (LitChar c)        = c == maxBound
 isMaxBound platform (LitNumber nt i)   = case nt of
    LitNumInt     -> i == platformMaxInt platform
+   LitNumInt8    -> i == toInteger (maxBound :: Int8)
+   LitNumInt16   -> i == toInteger (maxBound :: Int16)
+   LitNumInt32   -> i == toInteger (maxBound :: Int32)
    LitNumInt64   -> i == toInteger (maxBound :: Int64)
    LitNumWord    -> i == platformMaxWord platform
+   LitNumWord8   -> i == toInteger (maxBound :: Word8)
+   LitNumWord16  -> i == toInteger (maxBound :: Word16)
+   LitNumWord32  -> i == toInteger (maxBound :: Word32)
    LitNumWord64  -> i == toInteger (maxBound :: Word64)
    LitNumNatural -> False
    LitNumInteger -> False
@@ -697,6 +749,13 @@ subsumedByPrimOp primop = do
   matchPrimOpId primop primop_id
   return e
 
+-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`
+extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr
+extendNarrowPassthrough narrow_primop n = do
+  [Var primop_id `App` x] <- getArgs
+  matchPrimOpId narrow_primop primop_id
+  return (Var (mkPrimOpId AndOp) `App` x `App` Lit (LitNumber LitNumWord n))
+
 -- | narrow subsumes bitwise `and` with full mask (cf #16402):
 --
 --       narrowN (x .&. m)

compiler/GHC/Core/TyCon.hs

@@ -1440,12 +1440,12 @@ data PrimRep
   | Int8Rep       -- ^ Signed, 8-bit value
   | Int16Rep      -- ^ Signed, 16-bit value
   | Int32Rep      -- ^ Signed, 32-bit value
-  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)
+  | Int64Rep      -- ^ Signed, 64 bit value
   | IntRep        -- ^ Signed, word-sized value
   | Word8Rep      -- ^ Unsigned, 8 bit value
   | Word16Rep     -- ^ Unsigned, 16 bit value
   | Word32Rep     -- ^ Unsigned, 32 bit value
-  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)
+  | Word64Rep     -- ^ Unsigned, 64 bit value
   | WordRep       -- ^ Unsigned, word-sized value
   | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')
   | FloatRep

compiler/GHC/CoreToByteCode.hs

@@ -403,7 +403,7 @@ schemeR_wrk fvs nm original_body (args, body)
          p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
 
          -- make the arg bitmap
-         bits = argBits platform (reverse (map bcIdArgRep all_args))
+         bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))
          bitmap_size = genericLength bits
          bitmap = mkBitmap platform bits
      body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -508,13 +508,17 @@ schemeE d s p e
 -- Delegate tail-calls to schemeT.
 schemeE d s p e@(AnnApp _ _) = schemeT d s p e
 
-schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnLit lit)     = do
+    platform <- profilePlatform <$> getProfile
+    returnUnboxedAtom d s p e (typeArgRep platform (literalType lit))
 schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
 
 schemeE d s p e@(AnnVar v)
       -- See Note [Not-necessarily-lifted join points], step 3.
     | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]
-    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+    | isUnliftedType (idType v) = do
+        platform <- profilePlatform <$> getProfile
+        returnUnboxedAtom d s p e (bcIdArgRep platform v)
     | otherwise                 = schemeT d s p e
 
 schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
@@ -830,18 +834,19 @@ schemeT d s p app
    -- Case 2: Constructor application
    | Just con <- maybe_saturated_dcon
    , isUnboxedTupleDataCon con
-   = case args_r_to_l of
-        [arg1,arg2] | isVAtom arg1 ->
+   = do
+     platform <- profilePlatform <$> getProfile
+     case args_r_to_l of
+        [arg1,arg2] | isVAtom platform arg1 ->
                   unboxedTupleReturn d s p arg2
-        [arg1,arg2] | isVAtom arg2 ->
+        [arg1,arg2] | isVAtom platform arg2 ->
                   unboxedTupleReturn d s p arg1
         _other -> multiValException
 
    -- Case 3: Ordinary data constructor
    | Just con <- maybe_saturated_dcon
    = do alloc_con <- mkConAppCode d s p con args_r_to_l
-        dflags <- getDynFlags
-        let platform = targetPlatform dflags
+        platform <- profilePlatform <$> getProfile
         return (alloc_con         `appOL`
                 mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`
                 ENTER)
@@ -922,7 +927,9 @@ mkConAppCode orig_d _ p con args_r_to_l =
 
 unboxedTupleReturn
     :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+unboxedTupleReturn d s p arg = do
+   platform <- profilePlatform <$> getProfile
+   returnUnboxedAtom d s p arg (atomRep platform arg)
 
 -- -----------------------------------------------------------------------------
 -- Generate code for a tail-call
@@ -934,13 +941,14 @@ doTailCall
     -> Id
     -> [AnnExpr' Id DVarSet]
     -> BcM BCInstrList
-doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
+doTailCall init_d s p fn args = do
+   platform <- profilePlatform <$> getProfile
+   do_pushes init_d args (map (atomRep platform) args)
   where
   do_pushes !d [] reps = do
         ASSERT( null reps ) return ()
         (push_fn, sz) <- pushAtom d p (AnnVar fn)
-        dflags <- getDynFlags
-        let platform = targetPlatform dflags
+        platform <- profilePlatform <$> getProfile
         ASSERT( sz == wordSize platform ) return ()
         let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)
         return (push_fn `appOL` (slide `appOL` unitOL ENTER))
@@ -948,8 +956,7 @@ doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
       let (push_apply, n, rest_of_reps) = findPushSeq reps
           (these_args, rest_of_args) = splitAt n args
       (next_d, push_code) <- push_seq d these_args
-      dflags <- getDynFlags
-      let platform = targetPlatform dflags
+      platform <- profilePlatform <$> getProfile
       instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps
       --                          ^^^ for the PUSH_APPLY_ instruction
       return (push_code `appOL` (push_apply `consOL` instrs))
@@ -1137,8 +1144,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
           -- NB: unboxed tuple cases bind the scrut binder to the same offset
           -- as one of the alt binders, so we have to remove any duplicates here:
           rel_slots = nub $ map fromIntegral $ concatMap spread binds
-          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
-                              | otherwise                      = []
+          spread (id, offset) | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]
+                              | otherwise                                = []
                 where rel_offset = trunc16W $ bytesToWords platform (d - offset)
 
      alt_stuff <- mapM codeAlt alts
@@ -1157,7 +1164,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
      alt_bco' <- emitBc alt_bco
      let push_alts
             | isAlgCase = PUSH_ALTS alt_bco'
-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep platform bndr_ty)
      return (push_alts `consOL` scrut_code)
 
 
@@ -1374,7 +1381,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          -- slide and return
          d_after_r_min_s = bytesToWords platform (d_after_r - s)
          wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
-                        `snocOL` RETURN_UBX (toArgRep r_rep)
+                        `snocOL` RETURN_UBX (toArgRep platform r_rep)
          --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
      return (
          push_args `appOL`
@@ -1387,6 +1394,12 @@ primRepToFFIType platform r
      VoidRep     -> FFIVoid
      IntRep      -> signed_word
      WordRep     -> unsigned_word
+     Int8Rep     -> FFISInt8
+     Word8Rep    -> FFIUInt8
+     Int16Rep    -> FFISInt16
+     Word16Rep   -> FFIUInt16
+     Int32Rep    -> FFISInt32
+     Word32Rep   -> FFIUInt32
      Int64Rep    -> FFISInt64
      Word64Rep   -> FFIUInt64
      AddrRep     -> FFIPointer
@@ -1405,6 +1418,12 @@ mkDummyLiteral platform pr
    = case pr of
         IntRep    -> mkLitInt  platform 0
         WordRep   -> mkLitWord platform 0
+        Int8Rep   -> mkLitInt8 0
+        Word8Rep  -> mkLitWord8 0
+        Int16Rep  -> mkLitInt16 0
+        Word16Rep -> mkLitWord16 0
+        Int32Rep  -> mkLitInt32 0
+        Word32Rep -> mkLitWord32 0
         Int64Rep  -> mkLitInt64 0
         Word64Rep -> mkLitWord64 0
         AddrRep   -> LitNullAddr
@@ -1621,24 +1640,39 @@ pushAtom d p (AnnVar var)
 
 pushAtom _ _ (AnnLit lit) = do
      platform <- targetPlatform <$> getDynFlags
-     let code rep
-             = let size_words = WordOff (argRepSizeW platform rep)
-               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),
-                           wordsToBytes platform size_words)
+     let code :: PrimRep -> BcM (BCInstrList, ByteOff)
+         code rep =
+            return (unitOL instr, size_bytes)
+          where
+            size_bytes = ByteOff $ primRepSizeB platform rep
+            -- Here we handle the non-word-width cases specifically since we
+            -- must emit different bytecode for them.
+            instr =
+              case size_bytes of
+                1  -> PUSH_UBX8 lit
+                2  -> PUSH_UBX16 lit
+                4  -> PUSH_UBX32 lit
+                _  -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
 
      case lit of
-        LitLabel _ _ _  -> code N
-        LitFloat _      -> code F
-        LitDouble _     -> code D
-        LitChar _       -> code N
-        LitNullAddr     -> code N
-        LitString _     -> code N
-        LitRubbish      -> code N
+        LitLabel _ _ _  -> code AddrRep
+        LitFloat _      -> code FloatRep
+        LitDouble _     -> code DoubleRep
+        LitChar _       -> code WordRep
+        LitNullAddr     -> code AddrRep
+        LitString _     -> code AddrRep
+        LitRubbish      -> code WordRep
         LitNumber nt _  -> case nt of
-          LitNumInt     -> code N
-          LitNumWord    -> code N
-          LitNumInt64   -> code L
-          LitNumWord64  -> code L
+          LitNumInt     -> code IntRep
+          LitNumWord    -> code WordRep
+          LitNumInt8    -> code Int8Rep
+          LitNumWord8   -> code Word8Rep
+          LitNumInt16   -> code Int16Rep
+          LitNumWord16  -> code Word16Rep
+          LitNumInt32   -> code Int32Rep
+          LitNumWord32  -> code Word32Rep
+          LitNumInt64   -> code Int64Rep
+          LitNumWord64  -> code Word64Rep
           -- No LitInteger's or LitNatural's should be left by the time this is
           -- called. CorePrep should have converted them all to a real core
           -- representation.
@@ -1827,13 +1861,13 @@ lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff
 lookupBCEnv_maybe = Map.lookup
 
 idSizeW :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep
+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
 
 idSizeCon :: Platform -> Id -> ByteOff
 idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep
 
-bcIdArgRep :: Id -> ArgRep
-bcIdArgRep = toArgRep . bcIdPrimRep
+bcIdArgRep :: Platform -> Id -> ArgRep
+bcIdArgRep platform = toArgRep platform . bcIdPrimRep
 
 bcIdPrimRep :: Id -> PrimRep
 bcIdPrimRep id
@@ -1843,7 +1877,7 @@ bcIdPrimRep id
   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
 
 repSizeWords :: Platform -> PrimRep -> WordOff
-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)
+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
 
 isFollowableArg :: ArgRep -> Bool
 isFollowableArg P = True
@@ -1930,11 +1964,12 @@ bcViewLoop e =
       Nothing -> e
       Just e' -> bcViewLoop e'
 
-isVAtom :: AnnExpr' Var ann -> Bool
-isVAtom e | Just e' <- bcView e = isVAtom e'
-isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)
-isVAtom (AnnCoercion {})        = True
-isVAtom _                     = False
+isVAtom :: Platform -> AnnExpr' Var ann -> Bool
+isVAtom platform expr = case expr of
+   e | Just e' <- bcView e -> isVAtom platform e'
+   (AnnVar v)              -> isVoidArg (bcIdArgRep platform v)
+   (AnnCoercion {})        -> True
+   _                       -> False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
@@ -1949,8 +1984,8 @@ atomPrimRep (AnnCase _ _ ty _)      =
 atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
 
-atomRep :: AnnExpr' Id ann -> ArgRep
-atomRep e = toArgRep (atomPrimRep e)
+atomRep :: Platform -> AnnExpr' Id ann -> ArgRep
+atomRep platform e = toArgRep platform (atomPrimRep e)
 
 -- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
 -- has initial depth @original_depth@.  Return the values which the stack
@@ -1958,8 +1993,8 @@ atomRep e = toArgRep (atomPrimRep e)
 mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
 mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
 
-typeArgRep :: Type -> ArgRep
-typeArgRep = toArgRep . typePrimRep1
+typeArgRep :: Platform -> Type -> ArgRep
+typeArgRep platform = toArgRep platform . typePrimRep1
 
 -- -----------------------------------------------------------------------------
 -- The bytecode generator's monad

compiler/GHC/HsToCore/Foreign/Call.hs

@@ -21,9 +21,7 @@ where
 
 #include "HsVersions.h"
 
-
 import GHC.Prelude
-import GHC.Platform
 
 import GHC.Core
 
@@ -41,7 +39,6 @@ import GHC.Core.Type
 import GHC.Core.Multiplicity
 import GHC.Types.Id   ( Id )
 import GHC.Core.Coercion
-import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim
 import GHC.Core.TyCon
 import GHC.Builtin.Types
@@ -355,36 +352,13 @@ resultWrapper result_ty
   | Just (tycon, tycon_arg_tys) <- maybe_tc_app
   , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials
   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
-  = do { dflags <- getDynFlags
-       ; let platform = targetPlatform dflags
-       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
-       ; let narrow_wrapper = maybeNarrow platform tycon
-             marshal_con e  = Var (dataConWrapId data_con)
+  = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+       ; let marshal_con e  = Var (dataConWrapId data_con)
                               `mkTyApps` tycon_arg_tys
-                              `App` wrapper (narrow_wrapper e)
+                              `App` wrapper e
        ; return (maybe_ty, marshal_con) }
 
   | otherwise
   = pprPanic "resultWrapper" (ppr result_ty)
   where
     maybe_tc_app = splitTyConApp_maybe result_ty
-
--- When the result of a foreign call is smaller than the word size, we
--- need to sign- or zero-extend the result up to the word size.  The C
--- standard appears to say that this is the responsibility of the
--- caller, not the callee.
-
-maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)
-maybeNarrow platform tycon
-  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
-  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
-  | tycon `hasKey` int32TyConKey
-  , platformWordSizeInBytes platform > 4
-  = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
-
-  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
-  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
-  | tycon `hasKey` word32TyConKey
-  , platformWordSizeInBytes platform > 4
-  = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
-  | otherwise                     = id

compiler/GHC/HsToCore/Foreign/Decl.hs

@@ -849,6 +849,12 @@ primTyDescChar platform ty
  = case typePrimRep1 (getPrimTyOf ty) of
      IntRep      -> signed_word
      WordRep     -> unsigned_word
+     Int8Rep     -> 'B'
+     Word8Rep    -> 'b'
+     Int16Rep    -> 'S'
+     Word16Rep   -> 's'
+     Int32Rep    -> 'W'
+     Word32Rep   -> 'w'
      Int64Rep    -> 'L'
      Word64Rep   -> 'l'
      AddrRep     -> 'p'

compiler/GHC/HsToCore/Quote.hs

@@ -2784,11 +2784,10 @@ repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
 
 repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
 repLiteral (HsStringPrim _ bs)
-  = do platform <- getPlatform
-       word8_ty <- lookupType word8TyConName
+  = do word8_ty <- lookupType word8TyConName
        let w8s = unpack bs
            w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
-                                  [mkWordLit platform (toInteger w8)]) w8s
+                                  [mkWord8Lit (toInteger w8)]) w8s
        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
 repLiteral lit
   = do lit' <- case lit of

compiler/GHC/Runtime/Heap/Inspect.hs

@@ -467,6 +467,10 @@ repPrim t = rep where
     | t == wordPrimTyCon             = text $ show (build x :: Word)
     | t == floatPrimTyCon            = text $ show (build x :: Float)
     | t == doublePrimTyCon           = text $ show (build x :: Double)
+    | t == int8PrimTyCon             = text $ show (build x :: Int8)
+    | t == word8PrimTyCon            = text $ show (build x :: Word8)
+    | t == int16PrimTyCon            = text $ show (build x :: Int16)
+    | t == word16PrimTyCon           = text $ show (build x :: Word16)
     | t == int32PrimTyCon            = text $ show (build x :: Int32)
     | t == word32PrimTyCon           = text $ show (build x :: Word32)
     | t == int64PrimTyCon            = text $ show (build x :: Int64)

compiler/GHC/Runtime/Interpreter.hs

@@ -103,7 +103,7 @@ import qualified Data.ByteString.Lazy as LB
 import Data.Array ((!))
 import Data.IORef
 import Foreign hiding (void)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Exit
 import GHC.IO.Handle.Types (Handle)
@@ -395,7 +395,7 @@ getBreakpointVar hsc_env ref ix =
     mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
     mapM (mkFinalizedHValue hsc_env) mb
 
-getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure :: HscEnv -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
 getClosure hsc_env ref =
   withForeignRef ref $ \hval -> do
     mb <- iservCmd hsc_env (GetClosure hval)

compiler/GHC/Stg/Lift/Analysis.hs

@@ -497,7 +497,7 @@ closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePla
 idClosureFootprint:: Platform -> Id -> WordOff
 idClosureFootprint platform
   = StgToCmm.ArgRep.argRepSizeW platform
-  . StgToCmm.ArgRep.idArgRep
+  . StgToCmm.ArgRep.idArgRep platform
 
 -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
 -- as a result of lifting @f@ to top-level. If there was any growing closure

compiler/GHC/StgToCmm/ArgRep.hs

@@ -65,28 +65,33 @@ argRepString V16 = "V16"
 argRepString V32 = "V32"
 argRepString V64 = "V64"
 
-toArgRep :: PrimRep -> ArgRep
-toArgRep VoidRep           = V
-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 Int16Rep          = N  -- Gets widened to native word width for calls
-toArgRep Word16Rep         = N  -- Gets widened to native word width for calls
-toArgRep Int32Rep          = N  -- Gets widened to native word width for calls
-toArgRep Word32Rep         = N  -- Gets widened to native word width for calls
-toArgRep AddrRep           = N
-toArgRep Int64Rep          = L
-toArgRep Word64Rep         = L
-toArgRep FloatRep          = F
-toArgRep DoubleRep         = D
-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of
-                               16 -> V16
-                               32 -> V32
-                               64 -> V64
-                               _  -> error "toArgRep: bad vector primrep"
+toArgRep :: Platform -> PrimRep -> ArgRep
+toArgRep platform rep = case rep of
+   VoidRep           -> V
+   LiftedRep         -> P
+   UnliftedRep       -> P
+   IntRep            -> N
+   WordRep           -> N
+   Int8Rep           -> N  -- Gets widened to native word width for calls
+   Word8Rep          -> N  -- Gets widened to native word width for calls
+   Int16Rep          -> N  -- Gets widened to native word width for calls
+   Word16Rep         -> N  -- Gets widened to native word width for calls
+   Int32Rep          -> N  -- Gets widened to native word width for calls
+   Word32Rep         -> N  -- Gets widened to native word width for calls
+   AddrRep           -> N
+   Int64Rep          -> case platformWordSize platform of
+                           PW4 -> L
+                           PW8 -> N
+   Word64Rep         -> case platformWordSize platform of
+                           PW4 -> L
+                           PW8 -> N
+   FloatRep          -> F
+   DoubleRep         -> D
+   (VecRep len elem) -> case len*primElemRepSizeB elem of
+                           16 -> V16
+                           32 -> V32
+                           64 -> V64
+                           _  -> error "toArgRep: bad vector primrep"
 
 isNonV :: ArgRep -> Bool
 isNonV V = False
@@ -106,8 +111,8 @@ argRepSizeW platform = \case
   where
    ws       = platformWordSizeInBytes platform
 
-idArgRep :: Id -> ArgRep
-idArgRep = toArgRep . idPrimRep
+idArgRep :: Platform -> Id -> ArgRep
+idArgRep platform = toArgRep platform . idPrimRep
 
 -- This list of argument patterns should be kept in sync with at least
 -- the following: