diff options
| author | Moritz Angermann <moritz.angermann@gmail.com> | 2020-10-22 12:08:34 +0800 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-11-26 16:00:32 -0500 |
| commit | be5d74caab64abf9d986fc7290f62731db7e73e7 (patch) | |
| tree | 7b1f374333ff0fb0449e9c6834c2a8210cfba7c5 | |
| parent | 2ed3e6c0f179c06828712832d1176519cdfa82a6 (diff) | |
| download | haskell-be5d74caab64abf9d986fc7290f62731db7e73e7.tar.gz | |
[Sized Cmm] properly retain sizes.
This replaces all Word<N> = W<N># Word# and Int<N> = I<N># Int# with
Word<N> = W<N># Word<N># and Int<N> = I<N># Int<N>#, thus providing us
with properly sized primitives in the codegenerator instead of pretending
they are all full machine words.
This came up when implementing darwinpcs for arm64. The darwinpcs reqires
us to pack function argugments in excess of registers on the stack. While
most procedure call standards (pcs) assume arguments are just passed in
8 byte slots; and thus the caller does not know the exact signature to make
the call, darwinpcs requires us to adhere to the prototype, and thus have
the correct sizes. If we specify CInt in the FFI call, it should correspond
to the C int, and not just be Word sized, when it's only half the size.
This does change the expected output of T16402 but the new result is no
less correct as it eliminates the narrowing (instead of the `and` as was
previously done).
Bumps the array, bytestring, text, and binary submodules.
Co-Authored-By: Ben Gamari <ben@well-typed.com>
Metric Increase:
T13701
T14697
71 files changed, 1067 insertions, 582 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index 881753f6f2..cf0f72c50f 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/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 diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 52febf72d2..d06bc4a12b 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/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 diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index ecc71baa69..364f4f0300 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/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#" diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs index 92255f9ea0..ff8bacd6cc 100644 --- a/compiler/GHC/ByteCode/Asm.hs +++ b/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] diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs index 5c4c619b69..3a461fa03c 100644 --- a/compiler/GHC/Cmm.hs +++ b/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 diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index 08ab27c410..e1251c6c27 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/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 diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs index da99a0db07..a3606219da 100644 --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -1,4 +1,4 @@ -{-# 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) diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index d1f722febd..0733369679 100644 --- a/compiler/GHC/CmmToC.hs +++ b/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 diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 57976e836a..523c8e3d79 100644 --- a/compiler/GHC/Core.hs +++ b/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)) diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs index e02a470d7e..8eb920cdc9 100644 --- a/compiler/GHC/Core/Opt/ConstantFold.hs +++ b/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) diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index f8cb9737d9..96c7ea9dec 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -1387,6 +1387,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 +1411,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 +1633,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. diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index e580057b77..f28d476c05 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/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 diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index cae1d3f115..1dea63982f 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/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' diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 16d17fd82e..7f2d0b5d85 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/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 diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 1b912339e5..d5758cdfbd 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/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) diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 681f1461f1..18a8775cdd 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -102,6 +102,21 @@ cgTopRhsCon dflags id con args nv_args_w_offsets) = mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) + ; let + -- Decompose padding into units of length 8, 4, 2, or 1 bytes to + -- allow the implementation of mk_payload to use widthFromBytes, + -- which only handles these cases. + fix_padding (x@(Padding n off) : rest) + | n == 0 = fix_padding rest + | n `elem` [1,2,4,8] = x : fix_padding rest + | n > 8 = add_pad 8 + | n > 4 = add_pad 4 + | n > 2 = add_pad 2 + | otherwise = add_pad 1 + where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest) + fix_padding (x : rest) = x : fix_padding rest + fix_padding [] = [] + mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) mk_payload (FieldOff arg _) = do amode <- getArgAmode arg @@ -117,7 +132,7 @@ cgTopRhsCon dflags id con args info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds - ; payload <- mapM mk_payload nv_args_w_offsets + ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets) -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs -- NB2: all the amodes should be Lits! -- TODO (osa): Why? diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index 625e76f085..4d13d3960c 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1195,8 +1195,8 @@ emitPrimOp dflags primop = case primop of -- Int8# signed ops - Int8Extend -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform)) - Int8Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8) + Int8ExtendOp -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform)) + Int8NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8) Int8NegOp -> \args -> opTranslate args (MO_S_Neg W8) Int8AddOp -> \args -> opTranslate args (MO_Add W8) Int8SubOp -> \args -> opTranslate args (MO_Sub W8) @@ -1213,8 +1213,8 @@ emitPrimOp dflags primop = case primop of -- Word8# unsigned ops - Word8Extend -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform)) - Word8Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8) + Word8ExtendOp -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform)) + Word8NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8) Word8NotOp -> \args -> opTranslate args (MO_Not W8) Word8AddOp -> \args -> opTranslate args (MO_Add W8) Word8SubOp -> \args -> opTranslate args (MO_Sub W8) @@ -1231,8 +1231,8 @@ emitPrimOp dflags primop = case primop of -- Int16# signed ops - Int16Extend -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform)) - Int16Narrow -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16) + Int16ExtendOp -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform)) + Int16NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16) Int16NegOp -> \args -> opTranslate args (MO_S_Neg W16) Int16AddOp -> \args -> opTranslate args (MO_Add W16) Int16SubOp -> \args -> opTranslate args (MO_Sub W16) @@ -1249,8 +1249,8 @@ emitPrimOp dflags primop = case primop of -- Word16# unsigned ops - Word16Extend -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform)) - Word16Narrow -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16) + Word16ExtendOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform)) + Word16NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16) Word16NotOp -> \args -> opTranslate args (MO_Not W16) Word16AddOp -> \args -> opTranslate args (MO_Add W16) Word16SubOp -> \args -> opTranslate args (MO_Sub W16) @@ -1265,6 +1265,16 @@ emitPrimOp dflags primop = case primop of Word16LtOp -> \args -> opTranslate args (MO_U_Lt W16) Word16NeOp -> \args -> opTranslate args (MO_Ne W16) +-- Int32# signed ops + + Int32ExtendOp -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform)) + Int32NarrowOp -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32) + +-- Word32# unsigned ops + + Word32ExtendOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform)) + Word32NarrowOp -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32) + -- Char# ops CharEqOp -> \args -> opTranslate args (MO_Eq (wordWidth platform)) diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index dbb4481d72..8cca28cc5a 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -106,8 +106,14 @@ mkSimpleLit platform = \case (wordWidth platform) LitNullAddr -> zeroCLit platform (LitNumber LitNumInt i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumInt8 i) -> CmmInt i W8 + (LitNumber LitNumInt16 i) -> CmmInt i W16 + (LitNumber LitNumInt32 i) -> CmmInt i W32 (LitNumber LitNumInt64 i) -> CmmInt i W64 (LitNumber LitNumWord i) -> CmmInt i (wordWidth platform) + (LitNumber LitNumWord8 i) -> CmmInt i W8 + (LitNumber LitNumWord16 i) -> CmmInt i W16 + (LitNumber LitNumWord32 i) -> CmmInt i W32 (LitNumber LitNumWord64 i) -> CmmInt i W64 (LitFloat r) -> CmmFloat r W32 (LitDouble r) -> CmmFloat r W64 diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs index 461f4ac70a..a5c855a4fa 100644 --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -17,6 +17,12 @@ module GHC.Types.Literal -- ** Creating Literals , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt8, mkLitInt8Wrap + , mkLitWord8, mkLitWord8Wrap + , mkLitInt16, mkLitInt16Wrap + , mkLitWord16, mkLitWord16Wrap + , mkLitInt32, mkLitInt32Wrap + , mkLitWord32, mkLitWord32Wrap , mkLitInt64, mkLitInt64Wrap , mkLitWord64, mkLitWord64Wrap , mkLitFloat, mkLitDouble @@ -40,9 +46,13 @@ module GHC.Types.Literal -- ** Coercions , wordToIntLit, intToWordLit - , narrowLit , narrow8IntLit, narrow16IntLit, narrow32IntLit , narrow8WordLit, narrow16WordLit, narrow32WordLit + , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit + , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit + , extendIntLit, extendWordLit + , int8Lit, int16Lit, int32Lit + , word8Lit, word16Lit, word32Lit , charToIntLit, intToCharLit , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit , nullAddrLit, rubbishLit, floatToDoubleLit, doubleToFloatLit @@ -152,8 +162,14 @@ data LitNumType = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals]) | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals]) | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt8 -- ^ @Int8#@ - exactly 8 bits + | LitNumInt16 -- ^ @Int16#@ - exactly 16 bits + | LitNumInt32 -- ^ @Int32#@ - exactly 32 bits | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord8 -- ^ @Word8#@ - exactly 8 bits + | LitNumWord16 -- ^ @Word16#@ - exactly 16 bits + | LitNumWord32 -- ^ @Word32#@ - exactly 32 bits | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits deriving (Data,Enum,Eq,Ord) @@ -163,8 +179,14 @@ litNumIsSigned nt = case nt of LitNumInteger -> True LitNumNatural -> False LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True LitNumInt64 -> True LitNumWord -> False + LitNumWord8 -> False + LitNumWord16 -> False + LitNumWord32 -> False LitNumWord64 -> False {- @@ -290,6 +312,12 @@ wrapLitNumber platform v@(LitNumber nt i) = case nt of LitNumWord -> case platformWordSize platform of PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) + LitNumInt8 -> LitNumber nt (toInteger (fromIntegral i :: Int8)) + LitNumWord8 -> LitNumber nt (toInteger (fromIntegral i :: Word8)) + LitNumInt16 -> LitNumber nt (toInteger (fromIntegral i :: Int16)) + LitNumWord16 -> LitNumber nt (toInteger (fromIntegral i :: Word16)) + LitNumInt32 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) + LitNumWord32 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) LitNumInteger -> v @@ -305,7 +333,13 @@ litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool litNumCheckRange platform nt i = case nt of LitNumInt -> platformInIntRange platform i LitNumWord -> platformInWordRange platform i + LitNumInt8 -> inInt8Range i + LitNumInt16 -> inInt16Range i + LitNumInt32 -> inInt32Range i LitNumInt64 -> inInt64Range i + LitNumWord8 -> inWord8Range i + LitNumWord16 -> inWord16Range i + LitNumWord32 -> inWord32Range i LitNumWord64 -> inWord64Range i LitNumNatural -> i >= 0 LitNumInteger -> True @@ -364,6 +398,84 @@ mkLitWordWrapC platform i = (n, i /= i') where n@(LitNumber _ i') = mkLitWordWrap platform i +-- | Creates a 'Literal' of type @Int8#@ +mkLitInt8 :: Integer -> Literal +mkLitInt8 x = ASSERT2( inInt8Range x, integer x ) (mkLitInt8Unchecked x) + +-- | Creates a 'Literal' of type @Int8#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt8Wrap :: Platform -> Integer -> Literal +mkLitInt8Wrap platform i = wrapLitNumber platform $ mkLitInt8Unchecked i + +-- | Creates a 'Literal' of type @Int8#@ without checking its range. +mkLitInt8Unchecked :: Integer -> Literal +mkLitInt8Unchecked i = LitNumber LitNumInt8 i + +-- | Creates a 'Literal' of type @Word8#@ +mkLitWord8 :: Integer -> Literal +mkLitWord8 x = ASSERT2( inWord8Range x, integer x ) (mkLitWord8Unchecked x) + +-- | Creates a 'Literal' of type @Word8#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord8Wrap :: Platform -> Integer -> Literal +mkLitWord8Wrap platform i = wrapLitNumber platform $ mkLitWord8Unchecked i + +-- | Creates a 'Literal' of type @Word8#@ without checking its range. +mkLitWord8Unchecked :: Integer -> Literal +mkLitWord8Unchecked i = LitNumber LitNumWord8 i + +-- | Creates a 'Literal' of type @Int16#@ +mkLitInt16 :: Integer -> Literal +mkLitInt16 x = ASSERT2( inInt16Range x, integer x ) (mkLitInt16Unchecked x) + +-- | Creates a 'Literal' of type @Int16#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt16Wrap :: Platform -> Integer -> Literal +mkLitInt16Wrap platform i = wrapLitNumber platform $ mkLitInt16Unchecked i + +-- | Creates a 'Literal' of type @Int16#@ without checking its range. +mkLitInt16Unchecked :: Integer -> Literal +mkLitInt16Unchecked i = LitNumber LitNumInt16 i + +-- | Creates a 'Literal' of type @Word16#@ +mkLitWord16 :: Integer -> Literal +mkLitWord16 x = ASSERT2( inWord16Range x, integer x ) (mkLitWord16Unchecked x) + +-- | Creates a 'Literal' of type @Word16#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord16Wrap :: Platform -> Integer -> Literal +mkLitWord16Wrap platform i = wrapLitNumber platform $ mkLitWord16Unchecked i + +-- | Creates a 'Literal' of type @Word16#@ without checking its range. +mkLitWord16Unchecked :: Integer -> Literal +mkLitWord16Unchecked i = LitNumber LitNumWord16 i + +-- | Creates a 'Literal' of type @Int32#@ +mkLitInt32 :: Integer -> Literal +mkLitInt32 x = ASSERT2( inInt32Range x, integer x ) (mkLitInt32Unchecked x) + +-- | Creates a 'Literal' of type @Int32#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt32Wrap :: Platform -> Integer -> Literal +mkLitInt32Wrap platform i = wrapLitNumber platform $ mkLitInt32Unchecked i + +-- | Creates a 'Literal' of type @Int32#@ without checking its range. +mkLitInt32Unchecked :: Integer -> Literal +mkLitInt32Unchecked i = LitNumber LitNumInt32 i + +-- | Creates a 'Literal' of type @Word32#@ +mkLitWord32 :: Integer -> Literal +mkLitWord32 x = ASSERT2( inWord32Range x, integer x ) (mkLitWord32Unchecked x) + +-- | Creates a 'Literal' of type @Word32#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord32Wrap :: Platform -> Integer -> Literal +mkLitWord32Wrap platform i = wrapLitNumber platform $ mkLitWord32Unchecked i + +-- | Creates a 'Literal' of type @Word32#@ without checking its range. +mkLitWord32Unchecked :: Integer -> Literal +mkLitWord32Unchecked i = LitNumber LitNumWord32 i + -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) @@ -418,7 +530,20 @@ mkLitNatural x = ASSERT2( inNaturalRange x, integer x ) inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 -inInt64Range, inWord64Range :: Integer -> Bool +inInt8Range, inWord8Range, inInt16Range, inWord16Range :: Integer -> Bool +inInt32Range, inWord32Range, inInt64Range, inWord64Range :: Integer -> Bool +inInt8Range x = x >= toInteger (minBound :: Int8) && + x <= toInteger (maxBound :: Int8) +inWord8Range x = x >= toInteger (minBound :: Word8) && + x <= toInteger (maxBound :: Word8) +inInt16Range x = x >= toInteger (minBound :: Int16) && + x <= toInteger (maxBound :: Int16) +inWord16Range x = x >= toInteger (minBound :: Word16) && + x <= toInteger (maxBound :: Word16) +inInt32Range x = x >= toInteger (minBound :: Int32) && + x <= toInteger (maxBound :: Int32) +inWord32Range x = x >= toInteger (minBound :: Word32) && + x <= toInteger (maxBound :: Word32) inInt64Range x = x >= toInteger (minBound :: Int64) && x <= toInteger (maxBound :: Int64) inWord64Range x = x >= toInteger (minBound :: Word64) && @@ -466,6 +591,8 @@ mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) narrow8IntLit, narrow16IntLit, narrow32IntLit, narrow8WordLit, narrow16WordLit, narrow32WordLit, + int8Lit, int16Lit, int32Lit, + word8Lit, word16Lit, word32Lit, charToIntLit, intToCharLit, floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit, floatToDoubleLit, doubleToFloatLit @@ -489,16 +616,46 @@ intToWordLit platform (LitNumber LitNumInt i) intToWordLit _ l = pprPanic "intToWordLit" (ppr l) -- | Narrow a literal number (unchecked result range) -narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal -narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a)) -narrowLit _ l = pprPanic "narrowLit" (ppr l) - -narrow8IntLit = narrowLit (Proxy :: Proxy Int8) -narrow16IntLit = narrowLit (Proxy :: Proxy Int16) -narrow32IntLit = narrowLit (Proxy :: Proxy Int32) -narrow8WordLit = narrowLit (Proxy :: Proxy Word8) -narrow16WordLit = narrowLit (Proxy :: Proxy Word16) -narrow32WordLit = narrowLit (Proxy :: Proxy Word32) +narrowLit' :: forall a. Integral a => Proxy a -> LitNumType -> Literal -> Literal +narrowLit' _ nt' (LitNumber _ i) = LitNumber nt' (toInteger (fromInteger i :: a)) +narrowLit' _ _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit' (Proxy :: Proxy Int8) LitNumInt +narrow16IntLit = narrowLit' (Proxy :: Proxy Int16) LitNumInt +narrow32IntLit = narrowLit' (Proxy :: Proxy Int32) LitNumInt +narrow8WordLit = narrowLit' (Proxy :: Proxy Word8) LitNumWord +narrow16WordLit = narrowLit' (Proxy :: Proxy Word16) LitNumWord +narrow32WordLit = narrowLit' (Proxy :: Proxy Word32) LitNumWord + +narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, + narrowWord8Lit, narrowWord16Lit, narrowWord32Lit :: Literal -> Literal +narrowInt8Lit = narrowLit' (Proxy :: Proxy Int8) LitNumInt8 +narrowInt16Lit = narrowLit' (Proxy :: Proxy Int16) LitNumInt16 +narrowInt32Lit = narrowLit' (Proxy :: Proxy Int32) LitNumInt32 +narrowWord8Lit = narrowLit' (Proxy :: Proxy Word8) LitNumWord8 +narrowWord16Lit = narrowLit' (Proxy :: Proxy Word16) LitNumWord16 +narrowWord32Lit = narrowLit' (Proxy :: Proxy Word32) LitNumWord32 + +-- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g. +-- 'Int#'). +extendWordLit, extendIntLit :: Platform -> Literal -> Literal +extendWordLit platform (LitNumber _nt i) = mkLitWord platform i +extendWordLit _platform l = pprPanic "extendWordLit" (ppr l) +extendIntLit platform (LitNumber _nt i) = mkLitInt platform i +extendIntLit _platform l = pprPanic "extendIntLit" (ppr l) + +int8Lit (LitNumber _ i) = mkLitInt8 i +int8Lit l = pprPanic "int8Lit" (ppr l) +int16Lit (LitNumber _ i) = mkLitInt16 i +int16Lit l = pprPanic "int16Lit" (ppr l) +int32Lit (LitNumber _ i) = mkLitInt32 i +int32Lit l = pprPanic "int32Lit" (ppr l) +word8Lit (LitNumber _ i) = mkLitWord8 i +word8Lit l = pprPanic "word8Lit" (ppr l) +word16Lit (LitNumber _ i) = mkLitWord16 i +word16Lit l = pprPanic "word16Lit" (ppr l) +word32Lit (LitNumber _ i) = mkLitWord32 i +word32Lit l = pprPanic "word32Lit" (ppr l) charToIntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) charToIntLit l = pprPanic "charToIntLit" (ppr l) @@ -572,8 +729,14 @@ litIsTrivial (LitNumber nt _) = case nt of LitNumInteger -> False LitNumNatural -> False LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True LitNumInt64 -> True LitNumWord -> True + LitNumWord8 -> True + LitNumWord16 -> True + LitNumWord32 -> True LitNumWord64 -> True litIsTrivial _ = True @@ -585,8 +748,14 @@ litIsDupable platform x = case x of LitNumInteger -> platformInIntRange platform i LitNumNatural -> platformInWordRange platform i LitNumInt -> True + LitNumInt8 -> True + LitNumInt16 -> True + LitNumInt32 -> True LitNumInt64 -> True LitNumWord -> True + LitNumWord8 -> True + LitNumWord16 -> True + LitNumWord32 -> True LitNumWord64 -> True (LitString _) -> False _ -> True @@ -601,8 +770,14 @@ litIsLifted (LitNumber nt _) = case nt of LitNumInteger -> True LitNumNatural -> True LitNumInt -> False + LitNumInt8 -> False + LitNumInt16 -> False + LitNumInt32 -> False LitNumInt64 -> False LitNumWord -> False + LitNumWord8 -> False + LitNumWord16 -> False + LitNumWord32 -> False LitNumWord64 -> False litIsLifted _ = False @@ -623,8 +798,14 @@ literalType (LitNumber lt _) = case lt of LitNumInteger -> integerTy LitNumNatural -> naturalTy LitNumInt -> intPrimTy + LitNumInt8 -> int8PrimTy + LitNumInt16 -> int16PrimTy + LitNumInt32 -> int32PrimTy LitNumInt64 -> int64PrimTy LitNumWord -> wordPrimTy + LitNumWord8 -> word8PrimTy + LitNumWord16 -> word16PrimTy + LitNumWord32 -> word32PrimTy LitNumWord64 -> word64PrimTy literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) where @@ -700,8 +881,14 @@ pprLiteral add_par (LitNumber nt i) LitNumInteger -> pprIntegerVal add_par i LitNumNatural -> pprIntegerVal add_par i LitNumInt -> pprPrimInt i + LitNumInt8 -> pprPrimInt8 i + LitNumInt16 -> pprPrimInt16 i + LitNumInt32 -> pprPrimInt32 i LitNumInt64 -> pprPrimInt64 i LitNumWord -> pprPrimWord i + LitNumWord8 -> pprPrimWord8 i + LitNumWord16 -> pprPrimWord16 i + LitNumWord32 -> pprPrimWord32 i LitNumWord64 -> pprPrimWord64 i pprLiteral add_par (LitLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod) diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 3698c5a4b2..7cbd0c4ffd 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -62,7 +62,9 @@ module GHC.Utils.Outputable ( primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, primInt64Suffix, primWord64Suffix, primIntSuffix, - pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, + pprPrimChar, pprPrimInt, pprPrimWord, + pprPrimInt8, pprPrimInt16, pprPrimInt32, pprPrimInt64, + pprPrimWord8, pprPrimWord16, pprPrimWord32, pprPrimWord64, pprFastFilePath, pprFilePathString, @@ -1149,22 +1151,40 @@ pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs -- Postfix modifiers for unboxed literals. -- See Note [Printing of literals in Core] in "GHC.Types.Literal". primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc -primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc +primDoubleSuffix, primWordSuffix :: SDoc +primInt8Suffix, primWord8Suffix :: SDoc +primInt16Suffix, primWord16Suffix :: SDoc +primInt32Suffix, primWord32Suffix :: SDoc +primInt64Suffix, primWord64Suffix :: SDoc primCharSuffix = char '#' primFloatSuffix = char '#' primIntSuffix = char '#' primDoubleSuffix = text "##" primWordSuffix = text "##" -primInt64Suffix = text "L#" -primWord64Suffix = text "L##" +primInt8Suffix = text "#8" +primWord8Suffix = text "##8" +primInt16Suffix = text "#16" +primWord16Suffix = text "##16" +primInt32Suffix = text "#32" +primWord32Suffix = text "##32" +primInt64Suffix = text "#64" +primWord64Suffix = text "##64" -- | Special combinator for showing unboxed literals. pprPrimChar :: Char -> SDoc -pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc +pprPrimInt, pprPrimWord :: Integer -> SDoc +pprPrimInt8, pprPrimInt16, pprPrimInt32, pprPrimInt64 :: Integer -> SDoc +pprPrimWord8, pprPrimWord16, pprPrimWord32, pprPrimWord64 :: Integer -> SDoc pprPrimChar c = pprHsChar c <> primCharSuffix pprPrimInt i = integer i <> primIntSuffix pprPrimWord w = word w <> primWordSuffix +pprPrimInt8 i = integer i <> primInt8Suffix +pprPrimInt16 i = integer i <> primInt16Suffix +pprPrimInt32 i = integer i <> primInt32Suffix pprPrimInt64 i = integer i <> primInt64Suffix +pprPrimWord8 w = word w <> primWord8Suffix +pprPrimWord16 w = word w <> primWord16Suffix +pprPrimWord32 w = word w <> primWord32Suffix pprPrimWord64 w = word w <> primWord64Suffix --------------------- diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 2e42221d47..d29f71ab04 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -59,7 +59,7 @@ Executable ghc -- NB: this is never built by the bootstrapping GHC+libraries Build-depends: deepseq == 1.4.*, - ghc-prim >= 0.5.0 && < 0.8, + ghc-prim >= 0.5.0 && < 0.9, ghci == @ProjectVersionMunged@, haskeline == 0.8.*, exceptions == 0.10.*, diff --git a/libraries/array b/libraries/array -Subproject 10e6c7e0522367677e4c33cc1c56eb852ef1342 +Subproject c7a696e3e6d5a6b00d3e00ca694af916f15bcff diff --git a/libraries/base/GHC/Float.hs b/libraries/base/GHC/Float.hs index 67cc11f9a9..5b859b1db9 100644 --- a/libraries/base/GHC/Float.hs +++ b/libraries/base/GHC/Float.hs @@ -1394,7 +1394,7 @@ castWord32ToFloat :: Word32 -> Float castWord32ToFloat (W32# w#) = F# (stgWord32ToFloat w#) foreign import prim "stg_word32ToFloatzh" - stgWord32ToFloat :: Word# -> Float# + stgWord32ToFloat :: Word32# -> Float# -- | @'castFloatToWord32' f@ does a bit-for-bit copy from a floating-point value @@ -1407,7 +1407,7 @@ castFloatToWord32 :: Float -> Word32 castFloatToWord32 (F# f#) = W32# (stgFloatToWord32 f#) foreign import prim "stg_floatToWord32zh" - stgFloatToWord32 :: Float# -> Word# + stgFloatToWord32 :: Float# -> Word32# diff --git a/libraries/base/GHC/IO/Encoding/CodePage.hs b/libraries/base/GHC/IO/Encoding/CodePage.hs index 2532e071e6..6c77e65c41 100644 --- a/libraries/base/GHC/IO/Encoding/CodePage.hs +++ b/libraries/base/GHC/IO/Encoding/CodePage.hs @@ -174,7 +174,7 @@ indexInt (ConvArray p) (I# i) = I# (indexInt16OffAddr# p i) {-# INLINE indexWord8 #-} indexWord8 :: ConvArray Word8 -> Int -> Word8 -indexWord8 (ConvArray p) (I# i) = W8# (indexWord8OffAddr# p i) +indexWord8 (ConvArray p) (I# i) = W8# (narrowWord8# (indexWord8OffAddr# p i)) {-# INLINE indexChar #-} indexChar :: ConvArray Char -> Int -> Char diff --git a/libraries/base/GHC/IO/Encoding/UTF16.hs b/libraries/base/GHC/IO/Encoding/UTF16.hs index 192f30beb9..c77c131eef 100644 --- a/libraries/base/GHC/IO/Encoding/UTF16.hs +++ b/libraries/base/GHC/IO/Encoding/UTF16.hs @@ -342,8 +342,8 @@ utf16le_encode chr2 :: Word16 -> Word16 -> Char chr2 (W16# a#) (W16# b#) = C# (chr# (upper# +# lower# +# 0x10000#)) where - !x# = word2Int# a# - !y# = word2Int# b# + !x# = word2Int# (extendWord16# a#) + !y# = word2Int# (extendWord16# b#) !upper# = uncheckedIShiftL# (x# -# 0xD800#) 10# !lower# = y# -# 0xDC00# {-# INLINE chr2 #-} @@ -356,4 +356,3 @@ validate2 :: Word16 -> Word16 -> Bool validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF && x2 >= 0xDC00 && x2 <= 0xDFFF {-# INLINE validate2 #-} - diff --git a/libraries/base/GHC/IO/Encoding/UTF32.hs b/libraries/base/GHC/IO/Encoding/UTF32.hs index 26b5e448ca..c14b365a04 100644 --- a/libraries/base/GHC/IO/Encoding/UTF32.hs +++ b/libraries/base/GHC/IO/Encoding/UTF32.hs @@ -309,10 +309,10 @@ chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = C# (chr# (z1# +# z2# +# z3# +# z4#)) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# - !y3# = word2Int# x3# - !y4# = word2Int# x4# + !y1# = word2Int# (extendWord8# x1#) + !y2# = word2Int# (extendWord8# x2#) + !y3# = word2Int# (extendWord8# x3#) + !y4# = word2Int# (extendWord8# x4#) !z1# = uncheckedIShiftL# y1# 24# !z2# = uncheckedIShiftL# y2# 16# !z3# = uncheckedIShiftL# y3# 8# @@ -333,4 +333,3 @@ validate :: Char -> Bool validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF) where x1 = ord c {-# INLINE validate #-} - diff --git a/libraries/base/GHC/IO/Encoding/UTF8.hs b/libraries/base/GHC/IO/Encoding/UTF8.hs index 18d034ad15..d887a92960 100644 --- a/libraries/base/GHC/IO/Encoding/UTF8.hs +++ b/libraries/base/GHC/IO/Encoding/UTF8.hs @@ -11,7 +11,7 @@ -- Module : GHC.IO.Encoding.UTF8 -- Copyright : (c) The University of Glasgow, 2009 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable @@ -144,17 +144,17 @@ bom1 = 0xbb bom2 = 0xbf utf8_decode :: DecodeBuffer -utf8_decode +utf8_decode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let + = let loop !ir !ow | ow >= os = done OutputUnderflow ir ow | ir >= iw = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir case c0 of - _ | c0 <= 0x7f -> do + _ | c0 <= 0x7f -> do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) loop (ir+1) ow' | c0 >= 0xc0 && c0 <= 0xc1 -> invalid -- Overlong forms @@ -170,7 +170,7 @@ utf8_decode 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) c1 <- readWord8Buf iraw (ir+1) - if not (validate3 c0 c1 0x80) + if not (validate3 c0 c1 0x80) then invalid else done InputUnderflow ir ow _ -> do c1 <- readWord8Buf iraw (ir+1) @@ -215,7 +215,7 @@ utf8_encode :: EncodeBuffer utf8_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } - = let + = let done why !ir !ow = return (why, if ir == iw then input{ bufL=0, bufR=0 } else input{ bufL=ir }, @@ -255,7 +255,7 @@ utf8_encode -- ----------------------------------------------------------------------------- -- UTF-8 primitives, lifted from Data.Text.Fusion.Utf8 - + ord2 :: Char -> (Word8,Word8) ord2 c = assert (n >= 0x80 && n <= 0x07ff) (x1,x2) where @@ -283,8 +283,8 @@ ord4 c = assert (n >= 0x10000) (x1,x2,x3,x4) chr2 :: Word8 -> Word8 -> Char chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# + !y1# = word2Int# (extendWord8# x1#) + !y2# = word2Int# (extendWord8# x2#) !z1# = uncheckedIShiftL# (y1# -# 0xC0#) 6# !z2# = y2# -# 0x80# {-# INLINE chr2 #-} @@ -292,9 +292,9 @@ chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#)) chr3 :: Word8 -> Word8 -> Word8 -> Char chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#)) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# - !y3# = word2Int# x3# + !y1# = word2Int# (extendWord8# x1#) + !y2# = word2Int# (extendWord8# x2#) + !y3# = word2Int# (extendWord8# x3#) !z1# = uncheckedIShiftL# (y1# -# 0xE0#) 12# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 6# !z3# = y3# -# 0x80# @@ -304,10 +304,10 @@ chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) = C# (chr# (z1# +# z2# +# z3# +# z4#)) where - !y1# = word2Int# x1# - !y2# = word2Int# x2# - !y3# = word2Int# x3# - !y4# = word2Int# x4# + !y1# = word2Int# (extendWord8# x1#) + !y2# = word2Int# (extendWord8# x2#) + !y3# = word2Int# (extendWord8# x3#) + !y4# = word2Int# (extendWord8# x4#) !z1# = uncheckedIShiftL# (y1# -# 0xF0#) 18# !z2# = uncheckedIShiftL# (y2# -# 0x80#) 12# !z3# = uncheckedIShiftL# (y3# -# 0x80#) 6# @@ -346,7 +346,7 @@ validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool validate4 x1 x2 x3 x4 = validate4_1 || validate4_2 || validate4_3 - where + where validate4_1 = x1 == 0xF0 && between x2 0x90 0xBF && between x3 0x80 0xBF && @@ -359,4 +359,3 @@ validate4 x1 x2 x3 x4 = validate4_1 || between x2 0x80 0x8F && between x3 0x80 0xBF && between x4 0x80 0xBF - diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index 5449a79c8f..08827e92c4 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -59,7 +59,7 @@ import GHC.Show -- Int8 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# +data {-# CTYPE "HsInt8" #-} Int8 = I8# Int8# -- ^ 8-bit signed integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -69,8 +69,8 @@ instance Eq Int8 where (/=) = neInt8 eqInt8, neInt8 :: Int8 -> Int8 -> Bool -eqInt8 (I8# x) (I8# y) = isTrue# (x ==# y) -neInt8 (I8# x) (I8# y) = isTrue# (x /=# y) +eqInt8 (I8# x) (I8# y) = isTrue# ((extendInt8# x) ==# (extendInt8# y)) +neInt8 (I8# x) (I8# y) = isTrue# ((extendInt8# x) /=# (extendInt8# y)) {-# INLINE [1] eqInt8 #-} {-# INLINE [1] neInt8 #-} @@ -86,10 +86,10 @@ instance Ord Int8 where {-# INLINE [1] ltInt8 #-} {-# INLINE [1] leInt8 #-} gtInt8, geInt8, ltInt8, leInt8 :: Int8 -> Int8 -> Bool -(I8# x) `gtInt8` (I8# y) = isTrue# (x ># y) -(I8# x) `geInt8` (I8# y) = isTrue# (x >=# y) -(I8# x) `ltInt8` (I8# y) = isTrue# (x <# y) -(I8# x) `leInt8` (I8# y) = isTrue# (x <=# y) +(I8# x) `gtInt8` (I8# y) = isTrue# ((extendInt8# x) ># (extendInt8# y)) +(I8# x) `geInt8` (I8# y) = isTrue# ((extendInt8# x) >=# (extendInt8# y)) +(I8# x) `ltInt8` (I8# y) = isTrue# ((extendInt8# x) <# (extendInt8# y)) +(I8# x) `leInt8` (I8# y) = isTrue# ((extendInt8# x) <=# (extendInt8# y)) -- | @since 2.01 instance Show Int8 where @@ -97,16 +97,16 @@ instance Show Int8 where -- | @since 2.01 instance Num Int8 where - (I8# x#) + (I8# y#) = I8# (narrow8Int# (x# +# y#)) - (I8# x#) - (I8# y#) = I8# (narrow8Int# (x# -# y#)) - (I8# x#) * (I8# y#) = I8# (narrow8Int# (x# *# y#)) - negate (I8# x#) = I8# (narrow8Int# (negateInt# x#)) + (I8# x#) + (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) +# (extendInt8# y#))) + (I8# x#) - (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) -# (extendInt8# y#))) + (I8# x#) * (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) *# (extendInt8# y#))) + negate (I8# x#) = I8# (narrowInt8# (negateInt# (extendInt8# x#))) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I8# (narrow8Int# (integerToInt# i)) + fromInteger i = I8# (narrowInt8# (integerToInt# i)) -- | @since 2.01 instance Real Int8 where @@ -122,9 +122,9 @@ instance Enum Int8 where | otherwise = predError "Int8" toEnum i@(I# i#) | i >= fromIntegral (minBound::Int8) && i <= fromIntegral (maxBound::Int8) - = I8# i# + = I8# (narrowInt8# i#) | otherwise = toEnumError "Int8" i (minBound::Int8, maxBound::Int8) - fromEnum (I8# x#) = I# x# + fromEnum (I8# x#) = I# (extendInt8# x#) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen @@ -133,34 +133,34 @@ instance Integral Int8 where quot x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I8# (narrow8Int# (x# `quotInt#` y#)) + | otherwise = I8# (narrowInt8# ((extendInt8# x#) `quotInt#` (extendInt8# y#))) rem (I8# x#) y@(I8# y#) | y == 0 = divZeroError - | otherwise = I8# (narrow8Int# (x# `remInt#` y#)) + | otherwise = I8# (narrowInt8# ((extendInt8# x#) `remInt#` (extendInt8# y#))) div x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I8# (narrow8Int# (x# `divInt#` y#)) + | otherwise = I8# (narrowInt8# ((extendInt8# x#) `divInt#` (extendInt8# y#))) mod (I8# x#) y@(I8# y#) | y == 0 = divZeroError - | otherwise = I8# (narrow8Int# (x# `modInt#` y#)) + | otherwise = I8# (narrowInt8# ((extendInt8# x#) `modInt#` (extendInt8# y#))) quotRem x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `quotRemInt#` y# of + | otherwise = case (extendInt8# x#) `quotRemInt#` (extendInt8# y#) of (# q, r #) -> - (I8# (narrow8Int# q), - I8# (narrow8Int# r)) + (I8# (narrowInt8# q), + I8# (narrowInt8# r)) divMod x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `divModInt#` y# of + | otherwise = case (extendInt8# x#) `divModInt#` (extendInt8# y#) of (# d, m #) -> - (I8# (narrow8Int# d), - I8# (narrow8Int# m)) - toInteger (I8# x#) = IS x# + (I8# (narrowInt8# d), + I8# (narrowInt8# m)) + toInteger (I8# x#) = IS (extendInt8# x#) -- | @since 2.01 instance Bounded Int8 where @@ -184,34 +184,34 @@ instance Bits Int8 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I8# x#) .&. (I8# y#) = I8# (x# `andI#` y#) - (I8# x#) .|. (I8# y#) = I8# (x# `orI#` y#) - (I8# x#) `xor` (I8# y#) = I8# (x# `xorI#` y#) - complement (I8# x#) = I8# (notI# x#) + (I8# x#) .&. (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) `andI#` (extendInt8# y#))) + (I8# x#) .|. (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) `orI#` (extendInt8# y#))) + (I8# x#) `xor` (I8# y#) = I8# (narrowInt8# ((extendInt8# x#) `xorI#` (extendInt8# y#))) + complement (I8# x#) = I8# (narrowInt8# (notI# (extendInt8# x#))) (I8# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = I8# (narrow8Int# (x# `iShiftL#` i#)) - | otherwise = I8# (x# `iShiftRA#` negateInt# i#) + | isTrue# (i# >=# 0#) = I8# (narrowInt8# ((extendInt8# x#) `iShiftL#` i#)) + | otherwise = I8# (narrowInt8# ((extendInt8# x#) `iShiftRA#` negateInt# i#)) (I8# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = I8# (narrow8Int# (x# `iShiftL#` i#)) + | isTrue# (i# >=# 0#) = I8# (narrowInt8# ((extendInt8# x#) `iShiftL#` i#)) | otherwise = overflowError - (I8# x#) `unsafeShiftL` (I# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#)) + (I8# x#) `unsafeShiftL` (I# i#) = I8# (narrowInt8# ((extendInt8# x#) `uncheckedIShiftL#` i#)) (I8# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = I8# (x# `iShiftRA#` i#) + | isTrue# (i# >=# 0#) = I8# (narrowInt8# ((extendInt8# x#) `iShiftRA#` i#)) | otherwise = overflowError - (I8# x#) `unsafeShiftR` (I# i#) = I8# (x# `uncheckedIShiftRA#` i#) + (I8# x#) `unsafeShiftR` (I# i#) = I8# (narrowInt8# ((extendInt8# x#) `uncheckedIShiftRA#` i#)) (I8# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = I8# x# | otherwise - = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + = I8# (narrowInt8# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (8# -# i'#))))) where - !x'# = narrow8Word# (int2Word# x#) + !x'# = narrow8Word# (int2Word# (extendInt8# x#)) !i'# = word2Int# (int2Word# i# `and#` 7##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = True - popCount (I8# x#) = I# (word2Int# (popCnt8# (int2Word# x#))) + popCount (I8# x#) = I# (word2Int# (popCnt8# (int2Word# (extendInt8# x#)))) bit = bitDefault testBit = testBitDefault @@ -220,13 +220,13 @@ instance FiniteBits Int8 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 8 - countLeadingZeros (I8# x#) = I# (word2Int# (clz8# (int2Word# x#))) - countTrailingZeros (I8# x#) = I# (word2Int# (ctz8# (int2Word# x#))) + countLeadingZeros (I8# x#) = I# (word2Int# (clz8# (int2Word# (extendInt8# x#)))) + countTrailingZeros (I8# x#) = I# (word2Int# (ctz8# (int2Word# (extendInt8# x#)))) {-# RULES "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 -"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) -"fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#) +"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrowInt8# x#) +"fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# (extendInt8# x#)) #-} {-# RULES @@ -266,7 +266,7 @@ instance FiniteBits Int8 where -- Int16 is represented in the same way as Int. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# +data {-# CTYPE "HsInt16" #-} Int16 = I16# Int16# -- ^ 16-bit signed integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -276,8 +276,8 @@ instance Eq Int16 where (/=) = neInt16 eqInt16, neInt16 :: Int16 -> Int16 -> Bool -eqInt16 (I16# x) (I16# y) = isTrue# (x ==# y) -neInt16 (I16# x) (I16# y) = isTrue# (x /=# y) +eqInt16 (I16# x) (I16# y) = isTrue# ((extendInt16# x) ==# (extendInt16# y)) +neInt16 (I16# x) (I16# y) = isTrue# ((extendInt16# x) /=# (extendInt16# y)) {-# INLINE [1] eqInt16 #-} {-# INLINE [1] neInt16 #-} @@ -293,10 +293,10 @@ instance Ord Int16 where {-# INLINE [1] ltInt16 #-} {-# INLINE [1] leInt16 #-} gtInt16, geInt16, ltInt16, leInt16 :: Int16 -> Int16 -> Bool -(I16# x) `gtInt16` (I16# y) = isTrue# (x ># y) -(I16# x) `geInt16` (I16# y) = isTrue# (x >=# y) -(I16# x) `ltInt16` (I16# y) = isTrue# (x <# y) -(I16# x) `leInt16` (I16# y) = isTrue# (x <=# y) +(I16# x) `gtInt16` (I16# y) = isTrue# ((extendInt16# x) ># (extendInt16# y)) +(I16# x) `geInt16` (I16# y) = isTrue# ((extendInt16# x) >=# (extendInt16# y)) +(I16# x) `ltInt16` (I16# y) = isTrue# ((extendInt16# x) <# (extendInt16# y)) +(I16# x) `leInt16` (I16# y) = isTrue# ((extendInt16# x) <=# (extendInt16# y)) -- | @since 2.01 instance Show Int16 where @@ -304,16 +304,16 @@ instance Show Int16 where -- | @since 2.01 instance Num Int16 where - (I16# x#) + (I16# y#) = I16# (narrow16Int# (x# +# y#)) - (I16# x#) - (I16# y#) = I16# (narrow16Int# (x# -# y#)) - (I16# x#) * (I16# y#) = I16# (narrow16Int# (x# *# y#)) - negate (I16# x#) = I16# (narrow16Int# (negateInt# x#)) + (I16# x#) + (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) +# (extendInt16# y#))) + (I16# x#) - (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) -# (extendInt16# y#))) + (I16# x#) * (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) *# (extendInt16# y#))) + negate (I16# x#) = I16# (narrowInt16# (negateInt# (extendInt16# x#))) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I16# (narrow16Int# (integerToInt# i)) + fromInteger i = I16# (narrowInt16# (integerToInt# i)) -- | @since 2.01 instance Real Int16 where @@ -329,9 +329,9 @@ instance Enum Int16 where | otherwise = predError "Int16" toEnum i@(I# i#) | i >= fromIntegral (minBound::Int16) && i <= fromIntegral (maxBound::Int16) - = I16# i# + = I16# (narrowInt16# i#) | otherwise = toEnumError "Int16" i (minBound::Int16, maxBound::Int16) - fromEnum (I16# x#) = I# x# + fromEnum (I16# x#) = I# (extendInt16# x#) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen @@ -340,34 +340,34 @@ instance Integral Int16 where quot x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I16# (narrow16Int# (x# `quotInt#` y#)) + | otherwise = I16# (narrowInt16# ((extendInt16# x#) `quotInt#` (extendInt16# y#))) rem (I16# x#) y@(I16# y#) | y == 0 = divZeroError - | otherwise = I16# (narrow16Int# (x# `remInt#` y#)) + | otherwise = I16# (narrowInt16# ((extendInt16# x#) `remInt#` (extendInt16# y#))) div x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I16# (narrow16Int# (x# `divInt#` y#)) + | otherwise = I16# (narrowInt16# ((extendInt16# x#) `divInt#` (extendInt16# y#))) mod (I16# x#) y@(I16# y#) | y == 0 = divZeroError - | otherwise = I16# (narrow16Int# (x# `modInt#` y#)) + | otherwise = I16# (narrowInt16# ((extendInt16# x#) `modInt#` (extendInt16# y#))) quotRem x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `quotRemInt#` y# of + | otherwise = case (extendInt16# x#) `quotRemInt#` (extendInt16# y#) of (# q, r #) -> - (I16# (narrow16Int# q), - I16# (narrow16Int# r)) + (I16# (narrowInt16# q), + I16# (narrowInt16# r)) divMod x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `divModInt#` y# of + | otherwise = case (extendInt16# x#) `divModInt#` (extendInt16# y#) of (# d, m #) -> - (I16# (narrow16Int# d), - I16# (narrow16Int# m)) - toInteger (I16# x#) = IS x# + (I16# (narrowInt16# d), + I16# (narrowInt16# m)) + toInteger (I16# x#) = IS (extendInt16# x#) -- | @since 2.01 instance Bounded Int16 where @@ -391,34 +391,34 @@ instance Bits Int16 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I16# x#) .&. (I16# y#) = I16# (x# `andI#` y#) - (I16# x#) .|. (I16# y#) = I16# (x# `orI#` y#) - (I16# x#) `xor` (I16# y#) = I16# (x# `xorI#` y#) - complement (I16# x#) = I16# (notI# x#) + (I16# x#) .&. (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) `andI#` (extendInt16# y#))) + (I16# x#) .|. (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) `orI#` (extendInt16# y#))) + (I16# x#) `xor` (I16# y#) = I16# (narrowInt16# ((extendInt16# x#) `xorI#` (extendInt16# y#))) + complement (I16# x#) = I16# (narrowInt16# (notI# (extendInt16# x#))) (I16# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = I16# (narrow16Int# (x# `iShiftL#` i#)) - | otherwise = I16# (x# `iShiftRA#` negateInt# i#) + | isTrue# (i# >=# 0#) = I16# (narrowInt16# ((extendInt16# x#) `iShiftL#` i#)) + | otherwise = I16# (narrowInt16# ((extendInt16# x#) `iShiftRA#` negateInt# i#)) (I16# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = I16# (narrow16Int# (x# `iShiftL#` i#)) + | isTrue# (i# >=# 0#) = I16# (narrowInt16# ((extendInt16# x#) `iShiftL#` i#)) | otherwise = overflowError - (I16# x#) `unsafeShiftL` (I# i#) = I16# (narrow16Int# (x# `uncheckedIShiftL#` i#)) + (I16# x#) `unsafeShiftL` (I# i#) = I16# (narrowInt16# ((extendInt16# x#) `uncheckedIShiftL#` i#)) (I16# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = I16# (x# `iShiftRA#` i#) + | isTrue# (i# >=# 0#) = I16# (narrowInt16# ((extendInt16# x#) `iShiftRA#` i#)) | otherwise = overflowError - (I16# x#) `unsafeShiftR` (I# i#) = I16# (x# `uncheckedIShiftRA#` i#) + (I16# x#) `unsafeShiftR` (I# i#) = I16# (narrowInt16# ((extendInt16# x#) `uncheckedIShiftRA#` i#)) (I16# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = I16# x# | otherwise - = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + = I16# (narrowInt16# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (16# -# i'#))))) where - !x'# = narrow16Word# (int2Word# x#) + !x'# = narrow16Word# (int2Word# (extendInt16# x#)) !i'# = word2Int# (int2Word# i# `and#` 15##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = True - popCount (I16# x#) = I# (word2Int# (popCnt16# (int2Word# x#))) + popCount (I16# x#) = I# (word2Int# (popCnt16# (int2Word# (extendInt16# x#)))) bit = bitDefault testBit = testBitDefault @@ -427,15 +427,15 @@ instance FiniteBits Int16 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 16 - countLeadingZeros (I16# x#) = I# (word2Int# (clz16# (int2Word# x#))) - countTrailingZeros (I16# x#) = I# (word2Int# (ctz16# (int2Word# x#))) + countLeadingZeros (I16# x#) = I# (word2Int# (clz16# (int2Word# (extendInt16# x#)))) + countTrailingZeros (I16# x#) = I# (word2Int# (ctz16# (int2Word# (extendInt16# x#)))) {-# RULES -"fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) -"fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# x# +"fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (narrowInt16# (word2Int# (extendWord8# x#))) +"fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# (narrowInt16# (extendInt8# x#)) "fromIntegral/Int16->Int16" fromIntegral = id :: Int16 -> Int16 -"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#) -"fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#) +"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrowInt16# x#) +"fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# (extendInt16# x#)) #-} {-# RULES @@ -478,7 +478,7 @@ instance FiniteBits Int16 where -- from its logical range. #endif -data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# +data {-# CTYPE "HsInt32" #-} Int32 = I32# Int32# -- ^ 32-bit signed integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -488,8 +488,8 @@ instance Eq Int32 where (/=) = neInt32 eqInt32, neInt32 :: Int32 -> Int32 -> Bool -eqInt32 (I32# x) (I32# y) = isTrue# (x ==# y) -neInt32 (I32# x) (I32# y) = isTrue# (x /=# y) +eqInt32 (I32# x) (I32# y) = isTrue# ((extendInt32# x) ==# (extendInt32# y)) +neInt32 (I32# x) (I32# y) = isTrue# ((extendInt32# x) /=# (extendInt32# y)) {-# INLINE [1] eqInt32 #-} {-# INLINE [1] neInt32 #-} @@ -505,10 +505,10 @@ instance Ord Int32 where {-# INLINE [1] ltInt32 #-} {-# INLINE [1] leInt32 #-} gtInt32, geInt32, ltInt32, leInt32 :: Int32 -> Int32 -> Bool -(I32# x) `gtInt32` (I32# y) = isTrue# (x ># y) -(I32# x) `geInt32` (I32# y) = isTrue# (x >=# y) -(I32# x) `ltInt32` (I32# y) = isTrue# (x <# y) -(I32# x) `leInt32` (I32# y) = isTrue# (x <=# y) +(I32# x) `gtInt32` (I32# y) = isTrue# ((extendInt32# x) ># (extendInt32# y)) +(I32# x) `geInt32` (I32# y) = isTrue# ((extendInt32# x) >=# (extendInt32# y)) +(I32# x) `ltInt32` (I32# y) = isTrue# ((extendInt32# x) <# (extendInt32# y)) +(I32# x) `leInt32` (I32# y) = isTrue# ((extendInt32# x) <=# (extendInt32# y)) -- | @since 2.01 instance Show Int32 where @@ -516,16 +516,16 @@ instance Show Int32 where -- | @since 2.01 instance Num Int32 where - (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#)) - (I32# x#) - (I32# y#) = I32# (narrow32Int# (x# -# y#)) - (I32# x#) * (I32# y#) = I32# (narrow32Int# (x# *# y#)) - negate (I32# x#) = I32# (narrow32Int# (negateInt# x#)) + (I32# x#) + (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) +# (extendInt32# y#))) + (I32# x#) - (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) -# (extendInt32# y#))) + (I32# x#) * (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) *# (extendInt32# y#))) + negate (I32# x#) = I32# (narrowInt32# (negateInt# (extendInt32# x#))) abs x | x >= 0 = x | otherwise = negate x signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I32# (narrow32Int# (integerToInt# i)) + fromInteger i = I32# (narrowInt32# (integerToInt# i)) -- | @since 2.01 instance Enum Int32 where @@ -536,14 +536,14 @@ instance Enum Int32 where | x /= minBound = x - 1 | otherwise = predError "Int32" #if WORD_SIZE_IN_BITS == 32 - toEnum (I# i#) = I32# i# + toEnum (I# i#) = I32# (narrowInt32# i#) #else toEnum i@(I# i#) | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32) - = I32# i# + = I32# (narrowInt32# i#) | otherwise = toEnumError "Int32" i (minBound::Int32, maxBound::Int32) #endif - fromEnum (I32# x#) = I# x# + fromEnum (I32# x#) = I# (extendInt32# x#) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen @@ -552,42 +552,42 @@ instance Integral Int32 where quot x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I32# (narrow32Int# (x# `quotInt#` y#)) + | otherwise = I32# (narrowInt32# ((extendInt32# x#) `quotInt#` (extendInt32# y#))) rem (I32# x#) y@(I32# y#) | y == 0 = divZeroError -- The quotRem CPU instruction fails for minBound `quotRem` -1, -- but minBound `rem` -1 is well-defined (0). We therefore -- special-case it. | y == (-1) = 0 - | otherwise = I32# (narrow32Int# (x# `remInt#` y#)) + | otherwise = I32# (narrowInt32# ((extendInt32# x#) `remInt#` (extendInt32# y#))) div x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError | y == (-1) && x == minBound = overflowError -- Note [Order of tests] - | otherwise = I32# (narrow32Int# (x# `divInt#` y#)) + | otherwise = I32# (narrowInt32# ((extendInt32# x#) `divInt#` (extendInt32# y#))) mod (I32# x#) y@(I32# y#) | y == 0 = divZeroError -- The divMod CPU instruction fails for minBound `divMod` -1, -- but minBound `mod` -1 is well-defined (0). We therefore -- special-case it. | y == (-1) = 0 - | otherwise = I32# (narrow32Int# (x# `modInt#` y#)) + | otherwise = I32# (narrowInt32# ((extendInt32# x#) `modInt#` (extendInt32# y#))) quotRem x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `quotRemInt#` y# of + | otherwise = case (extendInt32# x#) `quotRemInt#` (extendInt32# y#) of (# q, r #) -> - (I32# (narrow32Int# q), - I32# (narrow32Int# r)) + (I32# (narrowInt32# q), + I32# (narrowInt32# r)) divMod x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError -- Note [Order of tests] | y == (-1) && x == minBound = (overflowError, 0) - | otherwise = case x# `divModInt#` y# of + | otherwise = case (extendInt32# x#) `divModInt#` (extendInt32# y#) of (# d, m #) -> - (I32# (narrow32Int# d), - I32# (narrow32Int# m)) - toInteger (I32# x#) = IS x# + (I32# (narrowInt32# d), + I32# (narrowInt32# m)) + toInteger (I32# x#) = IS (extendInt32# x#) -- | @since 2.01 instance Read Int32 where @@ -600,35 +600,35 @@ instance Bits Int32 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (I32# x#) .&. (I32# y#) = I32# (x# `andI#` y#) - (I32# x#) .|. (I32# y#) = I32# (x# `orI#` y#) - (I32# x#) `xor` (I32# y#) = I32# (x# `xorI#` y#) - complement (I32# x#) = I32# (notI# x#) + (I32# x#) .&. (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) `andI#` (extendInt32# y#))) + (I32# x#) .|. (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) `orI#` (extendInt32# y#))) + (I32# x#) `xor` (I32# y#) = I32# (narrowInt32# ((extendInt32# x#) `xorI#` (extendInt32# y#))) + complement (I32# x#) = I32# (narrowInt32# (notI# (extendInt32# x#))) (I32# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = I32# (narrow32Int# (x# `iShiftL#` i#)) - | otherwise = I32# (x# `iShiftRA#` negateInt# i#) + | isTrue# (i# >=# 0#) = I32# (narrowInt32# ((extendInt32# x#) `iShiftL#` i#)) + | otherwise = I32# (narrowInt32# ((extendInt32# x#) `iShiftRA#` negateInt# i#)) (I32# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = I32# (narrow32Int# (x# `iShiftL#` i#)) + | isTrue# (i# >=# 0#) = I32# (narrowInt32# ((extendInt32# x#) `iShiftL#` i#)) | otherwise = overflowError (I32# x#) `unsafeShiftL` (I# i#) = - I32# (narrow32Int# (x# `uncheckedIShiftL#` i#)) + I32# (narrowInt32# ((extendInt32# x#) `uncheckedIShiftL#` i#)) (I32# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = I32# (x# `iShiftRA#` i#) + | isTrue# (i# >=# 0#) = I32# (narrowInt32# ((extendInt32# x#) `iShiftRA#` i#)) | otherwise = overflowError - (I32# x#) `unsafeShiftR` (I# i#) = I32# (x# `uncheckedIShiftRA#` i#) + (I32# x#) `unsafeShiftR` (I# i#) = I32# (narrowInt32# ((extendInt32# x#) `uncheckedIShiftRA#` i#)) (I32# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = I32# x# | otherwise - = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + = I32# (narrowInt32# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` (x'# `uncheckedShiftRL#` (32# -# i'#))))) where - !x'# = narrow32Word# (int2Word# x#) + !x'# = narrow32Word# (int2Word# (extendInt32# x#)) !i'# = word2Int# (int2Word# i# `and#` 31##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = True - popCount (I32# x#) = I# (word2Int# (popCnt32# (int2Word# x#))) + popCount (I32# x#) = I# (word2Int# (popCnt32# (int2Word# (extendInt32# x#)))) bit = bitDefault testBit = testBitDefault @@ -637,17 +637,17 @@ instance FiniteBits Int32 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 32 - countLeadingZeros (I32# x#) = I# (word2Int# (clz32# (int2Word# x#))) - countTrailingZeros (I32# x#) = I# (word2Int# (ctz32# (int2Word# x#))) + countLeadingZeros (I32# x#) = I# (word2Int# (clz32# (int2Word# (extendInt32# x#)))) + countTrailingZeros (I32# x#) = I# (word2Int# (ctz32# (int2Word# (extendInt32# x#)))) {-# RULES -"fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (word2Int# x#) -"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#) -"fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x# -"fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# x# +"fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (narrowInt32# (word2Int# (extendWord8# x#))) +"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (narrowInt32# (word2Int# (extendWord16# x#))) +"fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# (narrowInt32# (extendInt8# x#)) +"fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# (narrowInt32# (extendInt16# x#)) "fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 -"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#) -"fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#) +"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrowInt32# x#) +"fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# (extendInt32# x#)) #-} {-# RULES diff --git a/libraries/base/GHC/Storable.hs b/libraries/base/GHC/Storable.hs index d9b9382211..359c136b2b 100644 --- a/libraries/base/GHC/Storable.hs +++ b/libraries/base/GHC/Storable.hs @@ -91,17 +91,17 @@ readDoubleOffPtr (Ptr a) (I# i) readStablePtrOffPtr (Ptr a) (I# i) = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #) readInt8OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# x #) + = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# (narrowInt8# x) #) readWord8OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #) + = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# (narrowWord8# x) #) readInt16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) + = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# (narrowInt16# x) #) readWord16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #) + = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# (narrowWord16# x) #) readInt32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) + = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# (narrowInt32# x) #) readWord32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #) + = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# (narrowWord32# x) #) readInt64OffPtr (Ptr a) (I# i) = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) readWord64OffPtr (Ptr a) (I# i) @@ -141,17 +141,17 @@ writeDoubleOffPtr (Ptr a) (I# i) (D# x) writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x) = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #) writeInt8OffPtr (Ptr a) (I# i) (I8# x) - = IO $ \s -> case writeInt8OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeInt8OffAddr# a i (extendInt8# x) s of s2 -> (# s2, () #) writeWord8OffPtr (Ptr a) (I# i) (W8# x) - = IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeWord8OffAddr# a i (extendWord8# x) s of s2 -> (# s2, () #) writeInt16OffPtr (Ptr a) (I# i) (I16# x) - = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeInt16OffAddr# a i (extendInt16# x) s of s2 -> (# s2, () #) writeWord16OffPtr (Ptr a) (I# i) (W16# x) - = IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeWord16OffAddr# a i (extendWord16# x) s of s2 -> (# s2, () #) writeInt32OffPtr (Ptr a) (I# i) (I32# x) - = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeInt32OffAddr# a i (extendInt32# x) s of s2 -> (# s2, () #) writeWord32OffPtr (Ptr a) (I# i) (W32# x) - = IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #) + = IO $ \s -> case writeWord32OffAddr# a i (extendWord32# x) s of s2 -> (# s2, () #) writeInt64OffPtr (Ptr a) (I# i) (I64# x) = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) writeWord64OffPtr (Ptr a) (I# i) (W64# x) diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 75ed7d1f73..4ff2cc4837 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -67,7 +67,10 @@ import GHC.Show -- Word8 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsWord8" #-} Word8 = W8# Word# +data {-# CTYPE "HsWord8" #-} Word8 + = W8# Word8# + + -- ^ 8-bit unsigned integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -77,8 +80,8 @@ instance Eq Word8 where (/=) = neWord8 eqWord8, neWord8 :: Word8 -> Word8 -> Bool -eqWord8 (W8# x) (W8# y) = isTrue# (x `eqWord#` y) -neWord8 (W8# x) (W8# y) = isTrue# (x `neWord#` y) +eqWord8 (W8# x) (W8# y) = isTrue# ((extendWord8# x) `eqWord#` (extendWord8# y)) +neWord8 (W8# x) (W8# y) = isTrue# ((extendWord8# x) `neWord#` (extendWord8# y)) {-# INLINE [1] eqWord8 #-} {-# INLINE [1] neWord8 #-} @@ -94,10 +97,10 @@ instance Ord Word8 where {-# INLINE [1] ltWord8 #-} {-# INLINE [1] leWord8 #-} gtWord8, geWord8, ltWord8, leWord8 :: Word8 -> Word8 -> Bool -(W8# x) `gtWord8` (W8# y) = isTrue# (x `gtWord#` y) -(W8# x) `geWord8` (W8# y) = isTrue# (x `geWord#` y) -(W8# x) `ltWord8` (W8# y) = isTrue# (x `ltWord#` y) -(W8# x) `leWord8` (W8# y) = isTrue# (x `leWord#` y) +(W8# x) `gtWord8` (W8# y) = isTrue# ((extendWord8# x) `gtWord#` (extendWord8# y)) +(W8# x) `geWord8` (W8# y) = isTrue# ((extendWord8# x) `geWord#` (extendWord8# y)) +(W8# x) `ltWord8` (W8# y) = isTrue# ((extendWord8# x) `ltWord#` (extendWord8# y)) +(W8# x) `leWord8` (W8# y) = isTrue# ((extendWord8# x) `leWord#` (extendWord8# y)) -- | @since 2.01 instance Show Word8 where @@ -105,14 +108,14 @@ instance Show Word8 where -- | @since 2.01 instance Num Word8 where - (W8# x#) + (W8# y#) = W8# (narrow8Word# (x# `plusWord#` y#)) - (W8# x#) - (W8# y#) = W8# (narrow8Word# (x# `minusWord#` y#)) - (W8# x#) * (W8# y#) = W8# (narrow8Word# (x# `timesWord#` y#)) - negate (W8# x#) = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#)))) + (W8# x#) + (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `plusWord#` (extendWord8# y#))) + (W8# x#) - (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `minusWord#` (extendWord8# y#))) + (W8# x#) * (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `timesWord#` (extendWord8# y#))) + negate (W8# x#) = W8# (narrowWord8# (int2Word# (negateInt# (word2Int# ((extendWord8# x#)))))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger i = W8# (narrow8Word# (integerToWord# i)) + fromInteger i = W8# (narrowWord8# (integerToWord# i)) -- | @since 2.01 instance Real Word8 where @@ -128,35 +131,36 @@ instance Enum Word8 where | otherwise = predError "Word8" toEnum i@(I# i#) | i >= 0 && i <= fromIntegral (maxBound::Word8) - = W8# (int2Word# i#) + = W8# (narrowWord8# (int2Word# i#)) | otherwise = toEnumError "Word8" i (minBound::Word8, maxBound::Word8) - fromEnum (W8# x#) = I# (word2Int# x#) + fromEnum (W8# x#) = I# (word2Int# (extendWord8# x#)) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen -- | @since 2.01 instance Integral Word8 where quot (W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `quotWord#` y#) + | y /= 0 = W8# (narrowWord8# ((extendWord8# x#) `quotWord#` (extendWord8# y#))) | otherwise = divZeroError rem (W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `remWord#` y#) + | y /= 0 = W8# (narrowWord8# ((extendWord8# x#) `remWord#` (extendWord8# y#))) | otherwise = divZeroError div (W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `quotWord#` y#) + | y /= 0 = W8# (narrowWord8# ((extendWord8# x#) `quotWord#` (extendWord8# y#))) | otherwise = divZeroError mod (W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `remWord#` y#) + | y /= 0 = W8# (narrowWord8# ((extendWord8# x#) `remWord#` (extendWord8# y#))) | otherwise = divZeroError quotRem (W8# x#) y@(W8# y#) - | y /= 0 = case x# `quotRemWord#` y# of + | y /= 0 = case (extendWord8# x#) `quotRemWord#` (extendWord8# y#) of (# q, r #) -> - (W8# q, W8# r) + (W8# (narrowWord8# q), W8# (narrowWord8# r)) | otherwise = divZeroError divMod (W8# x#) y@(W8# y#) - | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#)) + | y /= 0 = (W8# (narrowWord8# ((extendWord8# x#) `quotWord#` (extendWord8# y#))) + ,W8# (narrowWord8# ((extendWord8# x#) `remWord#` (extendWord8# y#)))) | otherwise = divZeroError - toInteger (W8# x#) = IS (word2Int# x#) + toInteger (W8# x#) = IS (word2Int# (extendWord8# x#)) -- | @since 2.01 instance Bounded Word8 where @@ -176,33 +180,32 @@ instance Bits Word8 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) - (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) - (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) - complement (W8# x#) = W8# (x# `xor#` mb#) - where !(W8# mb#) = maxBound + (W8# x#) .&. (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `and#` (extendWord8# y#))) + (W8# x#) .|. (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `or#` (extendWord8# y#))) + (W8# x#) `xor` (W8# y#) = W8# (narrowWord8# ((extendWord8# x#) `xor#` (extendWord8# y#))) + complement (W8# x#) = W8# (narrowWord8# (not# (extendWord8# x#))) (W8# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = W8# (narrow8Word# (x# `shiftL#` i#)) - | otherwise = W8# (x# `shiftRL#` negateInt# i#) + | isTrue# (i# >=# 0#) = W8# (narrowWord8# ((extendWord8# x#) `shiftL#` i#)) + | otherwise = W8# (narrowWord8# ((extendWord8# x#) `shiftRL#` negateInt# i#)) (W8# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = W8# (narrow8Word# (x# `shiftL#` i#)) + | isTrue# (i# >=# 0#) = W8# (narrowWord8# ((extendWord8# x#) `shiftL#` i#)) | otherwise = overflowError (W8# x#) `unsafeShiftL` (I# i#) = - W8# (narrow8Word# (x# `uncheckedShiftL#` i#)) + W8# (narrowWord8# ((extendWord8# x#) `uncheckedShiftL#` i#)) (W8# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = W8# (x# `shiftRL#` i#) + | isTrue# (i# >=# 0#) = W8# (narrowWord8# ((extendWord8# x#) `shiftRL#` i#)) | otherwise = overflowError - (W8# x#) `unsafeShiftR` (I# i#) = W8# (x# `uncheckedShiftRL#` i#) + (W8# x#) `unsafeShiftR` (I# i#) = W8# (narrowWord8# ((extendWord8# x#) `uncheckedShiftRL#` i#)) (W8# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W8# x# - | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (8# -# i'#)))) + | otherwise = W8# (narrowWord8# (((extendWord8# x#) `uncheckedShiftL#` i'#) `or#` + ((extendWord8# x#) `uncheckedShiftRL#` (8# -# i'#)))) where !i'# = word2Int# (int2Word# i# `and#` 7##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = False - popCount (W8# x#) = I# (word2Int# (popCnt8# x#)) + popCount (W8# x#) = I# (word2Int# (popCnt8# (extendWord8# x#))) bit = bitDefault testBit = testBitDefault @@ -211,14 +214,14 @@ instance FiniteBits Word8 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 8 - countLeadingZeros (W8# x#) = I# (word2Int# (clz8# x#)) - countTrailingZeros (W8# x#) = I# (word2Int# (ctz8# x#)) + countLeadingZeros (W8# x#) = I# (word2Int# (clz8# (extendWord8# x#))) + countTrailingZeros (W8# x#) = I# (word2Int# (ctz8# (extendWord8# x#))) {-# RULES "fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 "fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer -"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#) -"fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# x#) +"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrowWord8# x#) +"fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# (extendWord8# x#)) #-} {-# RULES @@ -258,7 +261,7 @@ instance FiniteBits Word8 where -- Word16 is represented in the same way as Word. Operations may assume -- and must ensure that it holds only values from its logical range. -data {-# CTYPE "HsWord16" #-} Word16 = W16# Word# +data {-# CTYPE "HsWord16" #-} Word16 = W16# Word16# -- ^ 16-bit unsigned integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -268,8 +271,8 @@ instance Eq Word16 where (/=) = neWord16 eqWord16, neWord16 :: Word16 -> Word16 -> Bool -eqWord16 (W16# x) (W16# y) = isTrue# (x `eqWord#` y) -neWord16 (W16# x) (W16# y) = isTrue# (x `neWord#` y) +eqWord16 (W16# x) (W16# y) = isTrue# ((extendWord16# x) `eqWord#` (extendWord16# y)) +neWord16 (W16# x) (W16# y) = isTrue# ((extendWord16# x) `neWord#` (extendWord16# y)) {-# INLINE [1] eqWord16 #-} {-# INLINE [1] neWord16 #-} @@ -285,10 +288,10 @@ instance Ord Word16 where {-# INLINE [1] ltWord16 #-} {-# INLINE [1] leWord16 #-} gtWord16, geWord16, ltWord16, leWord16 :: Word16 -> Word16 -> Bool -(W16# x) `gtWord16` (W16# y) = isTrue# (x `gtWord#` y) -(W16# x) `geWord16` (W16# y) = isTrue# (x `geWord#` y) -(W16# x) `ltWord16` (W16# y) = isTrue# (x `ltWord#` y) -(W16# x) `leWord16` (W16# y) = isTrue# (x `leWord#` y) +(W16# x) `gtWord16` (W16# y) = isTrue# ((extendWord16# x) `gtWord#` (extendWord16# y)) +(W16# x) `geWord16` (W16# y) = isTrue# ((extendWord16# x) `geWord#` (extendWord16# y)) +(W16# x) `ltWord16` (W16# y) = isTrue# ((extendWord16# x) `ltWord#` (extendWord16# y)) +(W16# x) `leWord16` (W16# y) = isTrue# ((extendWord16# x) `leWord#` (extendWord16# y)) -- | @since 2.01 instance Show Word16 where @@ -296,14 +299,14 @@ instance Show Word16 where -- | @since 2.01 instance Num Word16 where - (W16# x#) + (W16# y#) = W16# (narrow16Word# (x# `plusWord#` y#)) - (W16# x#) - (W16# y#) = W16# (narrow16Word# (x# `minusWord#` y#)) - (W16# x#) * (W16# y#) = W16# (narrow16Word# (x# `timesWord#` y#)) - negate (W16# x#) = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#)))) + (W16# x#) + (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `plusWord#` (extendWord16# y#))) + (W16# x#) - (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `minusWord#` (extendWord16# y#))) + (W16# x#) * (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `timesWord#` (extendWord16# y#))) + negate (W16# x#) = W16# (narrowWord16# (int2Word# (negateInt# (word2Int# (extendWord16# x#))))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger i = W16# (narrow16Word# (integerToWord# i)) + fromInteger i = W16# (narrowWord16# (integerToWord# i)) -- | @since 2.01 instance Real Word16 where @@ -319,35 +322,36 @@ instance Enum Word16 where | otherwise = predError "Word16" toEnum i@(I# i#) | i >= 0 && i <= fromIntegral (maxBound::Word16) - = W16# (int2Word# i#) + = W16# (narrowWord16# (int2Word# i#)) | otherwise = toEnumError "Word16" i (minBound::Word16, maxBound::Word16) - fromEnum (W16# x#) = I# (word2Int# x#) + fromEnum (W16# x#) = I# (word2Int# (extendWord16# x#)) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen -- | @since 2.01 instance Integral Word16 where quot (W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `quotWord#` y#) + | y /= 0 = W16# (narrowWord16# ((extendWord16# x#) `quotWord#` (extendWord16# y#))) | otherwise = divZeroError rem (W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `remWord#` y#) + | y /= 0 = W16# (narrowWord16# ((extendWord16# x#) `remWord#` (extendWord16# y#))) | otherwise = divZeroError div (W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `quotWord#` y#) + | y /= 0 = W16# (narrowWord16# ((extendWord16# x#) `quotWord#` (extendWord16# y#))) | otherwise = divZeroError mod (W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `remWord#` y#) + | y /= 0 = W16# (narrowWord16# ((extendWord16# x#) `remWord#` (extendWord16# y#))) | otherwise = divZeroError quotRem (W16# x#) y@(W16# y#) - | y /= 0 = case x# `quotRemWord#` y# of + | y /= 0 = case (extendWord16# x#) `quotRemWord#` (extendWord16# y#) of (# q, r #) -> - (W16# q, W16# r) + (W16# (narrowWord16# q), W16# (narrowWord16# r)) | otherwise = divZeroError divMod (W16# x#) y@(W16# y#) - | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#)) + | y /= 0 = (W16# (narrowWord16# ((extendWord16# x#) `quotWord#` (extendWord16# y#))) + ,W16# (narrowWord16# ((extendWord16# x#) `remWord#` (extendWord16# y#)))) | otherwise = divZeroError - toInteger (W16# x#) = IS (word2Int# x#) + toInteger (W16# x#) = IS (word2Int# (extendWord16# x#)) -- | @since 2.01 instance Bounded Word16 where @@ -367,33 +371,32 @@ instance Bits Word16 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) - (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) - (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) - complement (W16# x#) = W16# (x# `xor#` mb#) - where !(W16# mb#) = maxBound + (W16# x#) .&. (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `and#` (extendWord16# y#))) + (W16# x#) .|. (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `or#` (extendWord16# y#))) + (W16# x#) `xor` (W16# y#) = W16# (narrowWord16# ((extendWord16# x#) `xor#` (extendWord16# y#))) + complement (W16# x#) = W16# (narrowWord16# (not# (extendWord16# x#))) (W16# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = W16# (narrow16Word# (x# `shiftL#` i#)) - | otherwise = W16# (x# `shiftRL#` negateInt# i#) + | isTrue# (i# >=# 0#) = W16# (narrowWord16# ((extendWord16# x#) `shiftL#` i#)) + | otherwise = W16# (narrowWord16# ((extendWord16# x#) `shiftRL#` negateInt# i#)) (W16# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = W16# (narrow16Word# (x# `shiftL#` i#)) + | isTrue# (i# >=# 0#) = W16# (narrowWord16# ((extendWord16# x#) `shiftL#` i#)) | otherwise = overflowError (W16# x#) `unsafeShiftL` (I# i#) = - W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) + W16# (narrowWord16# ((extendWord16# x#) `uncheckedShiftL#` i#)) (W16# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = W16# (x# `shiftRL#` i#) + | isTrue# (i# >=# 0#) = W16# (narrowWord16# ((extendWord16# x#) `shiftRL#` i#)) | otherwise = overflowError - (W16# x#) `unsafeShiftR` (I# i#) = W16# (x# `uncheckedShiftRL#` i#) + (W16# x#) `unsafeShiftR` (I# i#) = W16# (narrowWord16# ((extendWord16# x#) `uncheckedShiftRL#` i#)) (W16# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W16# x# - | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (16# -# i'#)))) + | otherwise = W16# (narrowWord16# (((extendWord16# x#) `uncheckedShiftL#` i'#) `or#` + ((extendWord16# x#) `uncheckedShiftRL#` (16# -# i'#)))) where !i'# = word2Int# (int2Word# i# `and#` 15##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = False - popCount (W16# x#) = I# (word2Int# (popCnt16# x#)) + popCount (W16# x#) = I# (word2Int# (popCnt16# (extendWord16# x#))) bit = bitDefault testBit = testBitDefault @@ -402,21 +405,21 @@ instance FiniteBits Word16 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 16 - countLeadingZeros (W16# x#) = I# (word2Int# (clz16# x#)) - countTrailingZeros (W16# x#) = I# (word2Int# (ctz16# x#)) + countLeadingZeros (W16# x#) = I# (word2Int# (clz16# (extendWord16# x#))) + countTrailingZeros (W16# x#) = I# (word2Int# (ctz16# (extendWord16# x#))) -- | Reverse order of bytes in 'Word16'. -- -- @since 4.7.0.0 byteSwap16 :: Word16 -> Word16 -byteSwap16 (W16# w#) = W16# (narrow16Word# (byteSwap16# w#)) +byteSwap16 (W16# w#) = W16# (narrowWord16# (byteSwap16# (extendWord16# w#))) {-# RULES -"fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# +"fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# (narrowWord16# (extendWord8# x#)) "fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 "fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer -"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#) -"fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#) +"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrowWord16# x#) +"fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# (extendWord16# x#)) #-} {-# RULES @@ -492,7 +495,7 @@ byteSwap16 (W16# w#) = W16# (narrow16Word# (byteSwap16# w#)) #endif -data {-# CTYPE "HsWord32" #-} Word32 = W32# Word# +data {-# CTYPE "HsWord32" #-} Word32 = W32# Word32# -- ^ 32-bit unsigned integer type -- See GHC.Classes#matching_overloaded_methods_in_rules @@ -502,8 +505,8 @@ instance Eq Word32 where (/=) = neWord32 eqWord32, neWord32 :: Word32 -> Word32 -> Bool -eqWord32 (W32# x) (W32# y) = isTrue# (x `eqWord#` y) -neWord32 (W32# x) (W32# y) = isTrue# (x `neWord#` y) +eqWord32 (W32# x) (W32# y) = isTrue# ((extendWord32# x) `eqWord#` (extendWord32# y)) +neWord32 (W32# x) (W32# y) = isTrue# ((extendWord32# x) `neWord#` (extendWord32# y)) {-# INLINE [1] eqWord32 #-} {-# INLINE [1] neWord32 #-} @@ -519,21 +522,21 @@ instance Ord Word32 where {-# INLINE [1] ltWord32 #-} {-# INLINE [1] leWord32 #-} gtWord32, geWord32, ltWord32, leWord32 :: Word32 -> Word32 -> Bool -(W32# x) `gtWord32` (W32# y) = isTrue# (x `gtWord#` y) -(W32# x) `geWord32` (W32# y) = isTrue# (x `geWord#` y) -(W32# x) `ltWord32` (W32# y) = isTrue# (x `ltWord#` y) -(W32# x) `leWord32` (W32# y) = isTrue# (x `leWord#` y) +(W32# x) `gtWord32` (W32# y) = isTrue# ((extendWord32# x) `gtWord#` (extendWord32# y)) +(W32# x) `geWord32` (W32# y) = isTrue# ((extendWord32# x) `geWord#` (extendWord32# y)) +(W32# x) `ltWord32` (W32# y) = isTrue# ((extendWord32# x) `ltWord#` (extendWord32# y)) +(W32# x) `leWord32` (W32# y) = isTrue# ((extendWord32# x) `leWord#` (extendWord32# y)) -- | @since 2.01 instance Num Word32 where - (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#)) - (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#)) - (W32# x#) * (W32# y#) = W32# (narrow32Word# (x# `timesWord#` y#)) - negate (W32# x#) = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#)))) + (W32# x#) + (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `plusWord#` (extendWord32# y#))) + (W32# x#) - (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `minusWord#` (extendWord32# y#))) + (W32# x#) * (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `timesWord#` (extendWord32# y#))) + negate (W32# x#) = W32# (narrowWord32# (int2Word# (negateInt# (word2Int# (extendWord32# x#))))) abs x = x signum 0 = 0 signum _ = 1 - fromInteger i = W32# (narrow32Word# (integerToWord# i)) + fromInteger i = W32# (narrowWord32# (integerToWord# i)) -- | @since 2.01 instance Enum Word32 where @@ -548,19 +551,19 @@ instance Enum Word32 where #if WORD_SIZE_IN_BITS > 32 && i <= fromIntegral (maxBound::Word32) #endif - = W32# (int2Word# i#) + = W32# (narrowWord32# (int2Word# i#)) | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) #if WORD_SIZE_IN_BITS == 32 fromEnum x@(W32# x#) | x <= fromIntegral (maxBound::Int) - = I# (word2Int# x#) + = I# (word2Int# (extendWord32# x#)) | otherwise = fromEnumError "Word32" x enumFrom = integralEnumFrom enumFromThen = integralEnumFromThen enumFromTo = integralEnumFromTo enumFromThenTo = integralEnumFromThenTo #else - fromEnum (W32# x#) = I# (word2Int# x#) + fromEnum (W32# x#) = I# (word2Int# (extendWord32# x#)) enumFrom = boundedEnumFrom enumFromThen = boundedEnumFromThen #endif @@ -568,33 +571,34 @@ instance Enum Word32 where -- | @since 2.01 instance Integral Word32 where quot (W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord#` y#) + | y /= 0 = W32# (narrowWord32# ((extendWord32# x#) `quotWord#` (extendWord32# y#))) | otherwise = divZeroError rem (W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord#` y#) + | y /= 0 = W32# (narrowWord32# ((extendWord32# x#) `remWord#` (extendWord32# y#))) | otherwise = divZeroError div (W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord#` y#) + | y /= 0 = W32# (narrowWord32# ((extendWord32# x#) `quotWord#` (extendWord32# y#))) | otherwise = divZeroError mod (W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord#` y#) + | y /= 0 = W32# (narrowWord32# ((extendWord32# x#) `remWord#` (extendWord32# y#))) | otherwise = divZeroError quotRem (W32# x#) y@(W32# y#) - | y /= 0 = case x# `quotRemWord#` y# of + | y /= 0 = case (extendWord32# x#) `quotRemWord#` (extendWord32# y#) of (# q, r #) -> - (W32# q, W32# r) + (W32# (narrowWord32# q), W32# (narrowWord32# r)) | otherwise = divZeroError divMod (W32# x#) y@(W32# y#) - | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#)) + | y /= 0 = (W32# (narrowWord32# ((extendWord32# x#) `quotWord#` (extendWord32# y#))) + ,W32# (narrowWord32# ((extendWord32# x#) `remWord#` (extendWord32# y#)))) | otherwise = divZeroError toInteger (W32# x#) #if WORD_SIZE_IN_BITS == 32 | isTrue# (i# >=# 0#) = IS i# - | otherwise = integerFromWord# x# + | otherwise = integerFromWord# (extendWord32# x#) where - !i# = word2Int# x# + !i# = word2Int# (extendWord32# x#) #else - = IS (word2Int# x#) + = IS (word2Int# (extendWord32# x#)) #endif -- | @since 2.01 @@ -604,33 +608,32 @@ instance Bits Word32 where {-# INLINE testBit #-} {-# INLINE popCount #-} - (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) - (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) - (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) - complement (W32# x#) = W32# (x# `xor#` mb#) - where !(W32# mb#) = maxBound + (W32# x#) .&. (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `and#` (extendWord32# y#))) + (W32# x#) .|. (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `or#` (extendWord32# y#))) + (W32# x#) `xor` (W32# y#) = W32# (narrowWord32# ((extendWord32# x#) `xor#` (extendWord32# y#))) + complement (W32# x#) = W32# (narrowWord32# (not# (extendWord32# x#))) (W32# x#) `shift` (I# i#) - | isTrue# (i# >=# 0#) = W32# (narrow32Word# (x# `shiftL#` i#)) - | otherwise = W32# (x# `shiftRL#` negateInt# i#) + | isTrue# (i# >=# 0#) = W32# (narrowWord32# ((extendWord32# x#) `shiftL#` i#)) + | otherwise = W32# (narrowWord32# ((extendWord32# x#) `shiftRL#` negateInt# i#)) (W32# x#) `shiftL` (I# i#) - | isTrue# (i# >=# 0#) = W32# (narrow32Word# (x# `shiftL#` i#)) + | isTrue# (i# >=# 0#) = W32# (narrowWord32# ((extendWord32# x#) `shiftL#` i#)) | otherwise = overflowError (W32# x#) `unsafeShiftL` (I# i#) = - W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) + W32# (narrowWord32# ((extendWord32# x#) `uncheckedShiftL#` i#)) (W32# x#) `shiftR` (I# i#) - | isTrue# (i# >=# 0#) = W32# (x# `shiftRL#` i#) + | isTrue# (i# >=# 0#) = W32# (narrowWord32# ((extendWord32# x#) `shiftRL#` i#)) | otherwise = overflowError - (W32# x#) `unsafeShiftR` (I# i#) = W32# (x# `uncheckedShiftRL#` i#) + (W32# x#) `unsafeShiftR` (I# i#) = W32# (narrowWord32# ((extendWord32# x#) `uncheckedShiftRL#` i#)) (W32# x#) `rotate` (I# i#) | isTrue# (i'# ==# 0#) = W32# x# - | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (32# -# i'#)))) + | otherwise = W32# (narrowWord32# (((extendWord32# x#) `uncheckedShiftL#` i'#) `or#` + ((extendWord32# x#) `uncheckedShiftRL#` (32# -# i'#)))) where !i'# = word2Int# (int2Word# i# `and#` 31##) bitSizeMaybe i = Just (finiteBitSize i) bitSize i = finiteBitSize i isSigned _ = False - popCount (W32# x#) = I# (word2Int# (popCnt32# x#)) + popCount (W32# x#) = I# (word2Int# (popCnt32# (extendWord32# x#))) bit = bitDefault testBit = testBitDefault @@ -639,16 +642,16 @@ instance FiniteBits Word32 where {-# INLINE countLeadingZeros #-} {-# INLINE countTrailingZeros #-} finiteBitSize _ = 32 - countLeadingZeros (W32# x#) = I# (word2Int# (clz32# x#)) - countTrailingZeros (W32# x#) = I# (word2Int# (ctz32# x#)) + countLeadingZeros (W32# x#) = I# (word2Int# (clz32# (extendWord32# x#))) + countTrailingZeros (W32# x#) = I# (word2Int# (ctz32# (extendWord32# x#))) {-# RULES -"fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# x# -"fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# +"fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# (narrowWord32# (extendWord8# x#)) +"fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# (narrowWord32# (extendWord16# x#)) "fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 "fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer -"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#) -"fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#) +"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrowWord32# x#) +"fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# (extendWord32# x#)) #-} -- | @since 2.01 @@ -679,7 +682,7 @@ instance Ix Word32 where -- -- @since 4.7.0.0 byteSwap32 :: Word32 -> Word32 -byteSwap32 (W32# w#) = W32# (narrow32Word# (byteSwap32# w#)) +byteSwap32 (W32# w#) = W32# (narrowWord32# (byteSwap32# (extendWord32# w#))) ------------------------------------------------------------------------ -- type Word64 @@ -969,8 +972,7 @@ instance Bits Word64 where (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) - complement (W64# x#) = W64# (x# `xor#` mb#) - where !(W64# mb#) = maxBound + complement (W64# x#) = W64# (not# x#) (W64# x#) `shift` (I# i#) | isTrue# (i# >=# 0#) = W64# (x# `shiftL#` i#) | otherwise = W64# (x# `shiftRL#` negateInt# i#) @@ -1050,19 +1052,19 @@ byteSwap64 (W64# w#) = W64# (byteSwap# w#) -- -- @since 4.12.0.0 bitReverse8 :: Word8 -> Word8 -bitReverse8 (W8# w#) = W8# (narrow8Word# (bitReverse8# w#)) +bitReverse8 (W8# w#) = W8# (narrowWord8# (bitReverse8# (extendWord8# w#))) -- | Reverse the order of the bits in a 'Word16'. -- -- @since 4.12.0.0 bitReverse16 :: Word16 -> Word16 -bitReverse16 (W16# w#) = W16# (narrow16Word# (bitReverse16# w#)) +bitReverse16 (W16# w#) = W16# (narrowWord16# (bitReverse16# (extendWord16# w#))) -- | Reverse the order of the bits in a 'Word32'. -- -- @since 4.12.0.0 bitReverse32 :: Word32 -> Word32 -bitReverse32 (W32# w#) = W32# (narrow32Word# (bitReverse32# w#)) +bitReverse32 (W32# w#) = W32# (narrowWord32# (bitReverse32# (extendWord32# w#))) -- | Reverse the order of the bits in a 'Word64'. -- diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 5da92855f7..f620affcbf 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -88,7 +88,7 @@ Library build-depends: rts == 1.0, - ghc-prim >= 0.5.1.0 && < 0.8, + ghc-prim >= 0.5.1.0 && < 0.9, ghc-bignum >= 1.0 && < 2.0 exposed-modules: diff --git a/libraries/binary b/libraries/binary -Subproject dfaf780596328c9184758452b78288e8f405fcc +Subproject b224410161f112dd1133a787ded9831799589ce diff --git a/libraries/bytestring b/libraries/bytestring -Subproject e043aacfc4202a59ccae8b8c8cf0e1ad83a3f20 +Subproject 8b5d8d0da24aefdc4d950174bf396b32335d7e0 diff --git a/libraries/ghc-bignum/ghc-bignum.cabal b/libraries/ghc-bignum/ghc-bignum.cabal index bc478cf108..b1d600bd15 100644 --- a/libraries/ghc-bignum/ghc-bignum.cabal +++ b/libraries/ghc-bignum/ghc-bignum.cabal @@ -77,7 +77,7 @@ library ForeignFunctionInterface build-depends: - ghc-prim >= 0.5.1.0 && < 0.8 + ghc-prim >= 0.5.1.0 && < 0.9 hs-source-dirs: src/ include-dirs: include/ diff --git a/libraries/ghc-compact/ghc-compact.cabal b/libraries/ghc-compact/ghc-compact.cabal index 4c55e09e4e..7ddb956355 100644 --- a/libraries/ghc-compact/ghc-compact.cabal +++ b/libraries/ghc-compact/ghc-compact.cabal @@ -36,7 +36,7 @@ library UnboxedTuples CPP - build-depends: ghc-prim >= 0.5.3 && < 0.8, + build-depends: ghc-prim >= 0.5.3 && < 0.9, base >= 4.9.0 && < 4.17, bytestring >= 0.10.6.0 ghc-options: -Wall diff --git a/libraries/ghc-heap/ghc-heap.cabal.in b/libraries/ghc-heap/ghc-heap.cabal.in index a80d9f7ad3..e0f15abd3f 100644 --- a/libraries/ghc-heap/ghc-heap.cabal.in +++ b/libraries/ghc-heap/ghc-heap.cabal.in @@ -23,7 +23,7 @@ library default-language: Haskell2010 build-depends: base >= 4.9.0 && < 5.0 - , ghc-prim > 0.2 && < 0.8 + , ghc-prim > 0.2 && < 0.9 , rts == 1.0.* ghc-options: -Wall diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal index bca9225023..05fd60f09a 100644 --- a/libraries/ghc-prim/ghc-prim.cabal +++ b/libraries/ghc-prim/ghc-prim.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: ghc-prim -version: 0.7.0 +version: 0.8.0 -- NOTE: Don't forget to update ./changelog.md license: BSD-3-Clause license-file: LICENSE diff --git a/libraries/ghci/GHCi/BreakArray.hs b/libraries/ghci/GHCi/BreakArray.hs index a0f9d03bdc..05d13bda67 100644 --- a/libraries/ghci/GHCi/BreakArray.hs +++ b/libraries/ghci/GHCi/BreakArray.hs @@ -32,10 +32,20 @@ import Control.Monad import Data.Word import GHC.Word -import GHC.Exts +import GHC.Exts hiding (extendWord8#, narrowWord8#) import GHC.IO ( IO(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) +#if MIN_VERSION_base(4,16,0) +import GHC.Base (extendWord8#, narrowWord8#) +#else +narrowWord8#, extendWord8# :: Word# -> Word# +narrowWord8# w = w +extendWord8# w = w +{-# INLINE narrowWord8# #-} +{-# INLINE extendWord8# #-} +#endif + data BreakArray = BA (MutableByteArray# RealWorld) breakOff, breakOn :: Word8 @@ -96,7 +106,7 @@ newBreakArray entries@(I# sz) = do case breakOff of W8# off -> do let loop n | isTrue# (n ==# sz) = return () - | otherwise = do writeBA# array n off; loop (n +# 1#) + | otherwise = do writeBA# array n (extendWord8# off); loop (n +# 1#) loop 0# return $ BA array @@ -105,11 +115,11 @@ writeBA# array i word = IO $ \s -> case writeWord8Array# array i word s of { s -> (# s, () #) } writeBreakArray :: BreakArray -> Int -> Word8 -> IO () -writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i word +writeBreakArray (BA array) (I# i) (W8# word) = writeBA# array i (extendWord8# word) readBA# :: MutableByteArray# RealWorld -> Int# -> IO Word8 readBA# array i = IO $ \s -> - case readWord8Array# array i s of { (# s, c #) -> (# s, W8# c #) } + case readWord8Array# array i s of { (# s, c #) -> (# s, W8# (narrowWord8# c) #) } readBreakArray :: BreakArray -> Int -> IO Word8 readBreakArray (BA array) (I# i) = readBA# array i diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index e33b703b49..39ba3ccbe7 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -73,6 +73,7 @@ library Build-Depends: array == 0.5.*, base >= 4.8 && < 4.17, + ghc-prim >= 0.5.0 && < 0.9, binary == 0.8.*, bytestring == 0.10.*, containers >= 0.5 && < 0.7, diff --git a/libraries/text b/libraries/text -Subproject 80cb9ee2eb7141171171318bbd6760fe8001252 +Subproject f1a2e141a79ebc0a57ab2d641db00cef3ff60a4 diff --git a/rts/Libdw.c b/rts/Libdw.c index 9619479313..25399a00fe 100644 --- a/rts/Libdw.c +++ b/rts/Libdw.c @@ -133,6 +133,11 @@ int libdwLookupLocation(LibdwSession *session, Location *frame, Dwfl_Module *mod = dwfl_addrmodule(session->dwfl, addr); if (mod == NULL) return 1; + // avoid unaligned pointer value + // Using &frame->object_file as argument to dwfl_module_info leads to + // + // error: taking address of packed member of ‘struct Location_’ may result in an unaligned pointer value [-Werror=address-of-packed-member] + // void *object_file = &frame->object_file; dwfl_module_info(mod, NULL, NULL, NULL, NULL, NULL, object_file, NULL); diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py index 4828df9736..cfc65d38d6 100644 --- a/testsuite/driver/testlib.py +++ b/testsuite/driver/testlib.py @@ -2163,7 +2163,7 @@ def normalise_callstacks(s: str) -> str: s = re.sub(r'CallStack \(from -prof\):(\n .*)*\n?', '', s) return s -tyCon_re = re.compile(r'TyCon\s*\d+L?\#\#\s*\d+L?\#\#\s*', flags=re.MULTILINE) +tyCon_re = re.compile(r'TyCon\s*\d+L?\#\#(64)?\s*\d+L?\#\#(64)?\s*', flags=re.MULTILINE) def normalise_type_reps(s: str) -> str: """ Normalise out fingerprints from Typeable TyCon representations """ diff --git a/testsuite/tests/array/should_run/arr020.hs b/testsuite/tests/array/should_run/arr020.hs index bb025eff03..db715b054e 100644 --- a/testsuite/tests/array/should_run/arr020.hs +++ b/testsuite/tests/array/should_run/arr020.hs @@ -20,12 +20,12 @@ newByteArray (I# n#) writeByteArray :: MutableByteArray s -> Int -> Word32 -> ST s () writeByteArray (MutableByteArray mba#) (I# i#) (W32# w#) - = ST $ \s# -> case writeWord32Array# mba# i# w# s# of + = ST $ \s# -> case writeWord32Array# mba# i# (extendWord32# w#) s# of s'# -> (# s'#, () #) indexArray :: ByteArray Word32 -> Int -> Word32 indexArray (ByteArray arr#) (I# i#) - = W32# (indexWord32Array# arr# i#) + = W32# (narrowWord32# (indexWord32Array# arr# i#)) unsafeFreezeByteArray :: MutableByteArray s -> ST s (ByteArray e) unsafeFreezeByteArray (MutableByteArray mba#) @@ -68,7 +68,7 @@ unsafeFreezeArrayArray (MutableArrayArray marrs#) (# s'#, arrs# #) -> (# s'#, ArrayArray arrs# #) unsafeDeepFreezeArrayArray :: forall s e - . MutableArrayArray s (MutableByteArray s) + . MutableArrayArray s (MutableByteArray s) -> ST s (ArrayArray (ByteArray e)) unsafeDeepFreezeArrayArray marrs@(MutableArrayArray marrs#) = do { let n = I# (sizeofMutableArrayArray# marrs#) @@ -112,7 +112,7 @@ newUnboxedArray2D values } unboxedArray2D :: UnboxedArray2D Word32 -unboxedArray2D +unboxedArray2D = newUnboxedArray2D [ [1..10] , [11..200] @@ -125,7 +125,7 @@ indexUnboxedArray2D :: UnboxedArray2D Word32 -> (Int, Int) -> Word32 indexUnboxedArray2D arr (i, j) = indexArrayArray arr i `indexArray` j -main +main = do { print $ unboxedArray2D `indexUnboxedArray2D` (3, 1000) ; performGC ; print $ unboxedArray2D `indexUnboxedArray2D` (3, 1000) diff --git a/testsuite/tests/backpack/should_compile/bkp16.stderr b/testsuite/tests/backpack/should_compile/bkp16.stderr index f035aae2e1..d09d6e6823 100644 --- a/testsuite/tests/backpack/should_compile/bkp16.stderr +++ b/testsuite/tests/backpack/should_compile/bkp16.stderr @@ -4,5 +4,5 @@ Instantiating q [1 of 1] Including p[Int=base-4.13.0.0:GHC.Exts] Instantiating p[Int=base-4.13.0.0:GHC.Exts] - [1 of 1] Including ghc-prim-0.7.0 + [1 of 1] Including ghc-prim-0.8.0 [1 of 1] Compiling Int[sig] ( p/Int.hsig, bkp16.out/p/p-97PZnzqiJmd2hTwUNGdjod/Int.o ) diff --git a/testsuite/tests/codeGen/should_run/cgrun070.hs b/testsuite/tests/codeGen/should_run/cgrun070.hs index d37032a707..53f640116f 100644 --- a/testsuite/tests/codeGen/should_run/cgrun070.hs +++ b/testsuite/tests/codeGen/should_run/cgrun070.hs @@ -196,11 +196,11 @@ touch a = unsafeIOToST $ IO $ \s# -> indexWord8Array :: ByteArray -> Int -> Word8 indexWord8Array arr (I# i#) = case indexWord8Array# (unBA arr) i# of - a -> W8# a + a -> W8# (narrowWord8# a) writeWord8Array :: MByteArray s -> Int -> Word8 -> ST s () writeWord8Array marr (I# i#) (W8# a) = ST $ \ s# -> - case writeWord8Array# (unMBA marr) i# a s# of + case writeWord8Array# (unMBA marr) i# (extendWord8# a) s# of s2# -> (# s2#, () #) unsafeFreezeByteArray :: MByteArray s -> ST s (ByteArray) diff --git a/testsuite/tests/codeGen/should_run/cgrun072.hs b/testsuite/tests/codeGen/should_run/cgrun072.hs index 403bc49a3c..fb1b26252f 100644 --- a/testsuite/tests/codeGen/should_run/cgrun072.hs +++ b/testsuite/tests/codeGen/should_run/cgrun072.hs @@ -31,10 +31,10 @@ main = do putStrLn test_primop_bSwap16 putStrLn test'_base_bSwap64 bswap16 :: Word16 -> Word16 -bswap16 (W16# w#) = W16# (narrow16Word# (byteSwap16# w#)) +bswap16 (W16# w#) = W16# (narrowWord16# (byteSwap16# (extendWord16# w#))) bswap32 :: Word32 -> Word32 -bswap32 (W32# w#) = W32# (narrow32Word# (byteSwap32# w#)) +bswap32 (W32# w#) = W32# (narrowWord32# (byteSwap32# (extendWord32# w#))) bswap64 :: Word64 -> Word64 bswap64 (W64# w#) = W64# (byteSwap64# w#) diff --git a/testsuite/tests/codeGen/should_run/cgrun075.hs b/testsuite/tests/codeGen/should_run/cgrun075.hs index 09e35b4d8a..89a4679e5f 100644 --- a/testsuite/tests/codeGen/should_run/cgrun075.hs +++ b/testsuite/tests/codeGen/should_run/cgrun075.hs @@ -27,13 +27,13 @@ instance Pdep Word where pdep (W# src#) (W# mask#) = W# (pdep# src# mask#) instance Pdep Word8 where - pdep (W8# src#) (W8# mask#) = W8# (pdep8# src# mask#) + pdep (W8# src#) (W8# mask#) = W8# (narrowWord8# (pdep8# (extendWord8# src#) (extendWord8# mask#))) instance Pdep Word16 where - pdep (W16# src#) (W16# mask#) = W16# (pdep16# src# mask#) + pdep (W16# src#) (W16# mask#) = W16# (narrowWord16# (pdep16# (extendWord16# src#) (extendWord16# mask#))) instance Pdep Word32 where - pdep (W32# src#) (W32# mask#) = W32# (pdep32# src# mask#) + pdep (W32# src#) (W32# mask#) = W32# (narrowWord32# (pdep32# (extendWord32# src#) (extendWord32# mask#))) instance Pdep Word64 where pdep (W64# src#) (W64# mask#) = W64# (pdep64# src# mask#) diff --git a/testsuite/tests/codeGen/should_run/cgrun076.hs b/testsuite/tests/codeGen/should_run/cgrun076.hs index 7fa42d74e0..a6ae331cf6 100644 --- a/testsuite/tests/codeGen/should_run/cgrun076.hs +++ b/testsuite/tests/codeGen/should_run/cgrun076.hs @@ -27,13 +27,13 @@ instance Pext Word where pext (W# src#) (W# mask#) = W# (pext# src# mask#) instance Pext Word8 where - pext (W8# src#) (W8# mask#) = W8# (pext8# src# mask#) + pext (W8# src#) (W8# mask#) = W8# (narrowWord8# (pext8# (extendWord8# src#) (extendWord8# mask#))) instance Pext Word16 where - pext (W16# src#) (W16# mask#) = W16# (pext16# src# mask#) + pext (W16# src#) (W16# mask#) = W16# (narrowWord16# (pext16# (extendWord16# src#) (extendWord16# mask#))) instance Pext Word32 where - pext (W32# src#) (W32# mask#) = W32# (pext32# src# mask#) + pext (W32# src#) (W32# mask#) = W32# (narrowWord32# (pext32# (extendWord32# src#) (extendWord32# mask#))) instance Pext Word64 where pext (W64# src#) (W64# mask#) = W64# (pext64# src# mask#) diff --git a/testsuite/tests/codeGen/should_run/compareByteArrays.hs b/testsuite/tests/codeGen/should_run/compareByteArrays.hs index 5bd0e58588..e155bc45a5 100644 --- a/testsuite/tests/codeGen/should_run/compareByteArrays.hs +++ b/testsuite/tests/codeGen/should_run/compareByteArrays.hs @@ -39,7 +39,7 @@ copyByteArray (BA# src#) (I# srcOfs#) (MBA# dest#) (I# destOfs#) (I# n#) indexWord8Array :: BA -> Int -> Word8 indexWord8Array (BA# ba#) (I# i#) - = W8# (indexWord8Array# ba# i#) + = W8# (narrowWord8# (indexWord8Array# ba# i#)) sizeofByteArray :: BA -> Int sizeofByteArray (BA# ba#) = I# (sizeofByteArray# ba#) @@ -54,7 +54,7 @@ newByteArray (I# n#) writeWord8Array :: MBA s -> Int -> Word8 -> ST s () writeWord8Array (MBA# mba#) (I# i#) (W8# j#) - = ST $ \s -> case writeWord8Array# mba# i# j# s of + = ST $ \s -> case writeWord8Array# mba# i# (extendWord8# j#) s of s' -> (# s', () #) unsafeFreezeByteArray :: MBA s -> ST s BA diff --git a/testsuite/tests/dependent/should_compile/T14729.stderr b/testsuite/tests/dependent/should_compile/T14729.stderr index f3e8a1fdf9..60707bb193 100644 --- a/testsuite/tests/dependent/should_compile/T14729.stderr +++ b/testsuite/tests/dependent/should_compile/T14729.stderr @@ -11,4 +11,4 @@ COERCION AXIOMS FAMILY INSTANCES type instance F Int = Bool -- Defined at T14729.hs:10:15 Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/dependent/should_compile/T15743.stderr b/testsuite/tests/dependent/should_compile/T15743.stderr index 4aeecbcc23..20bfaafadb 100644 --- a/testsuite/tests/dependent/should_compile/T15743.stderr +++ b/testsuite/tests/dependent/should_compile/T15743.stderr @@ -3,4 +3,4 @@ TYPE CONSTRUCTORS forall {k1} k2 (k3 :: k2). Proxy k3 -> k1 -> k2 -> * roles nominal nominal nominal phantom phantom phantom Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/dependent/should_compile/T15743e.stderr b/testsuite/tests/dependent/should_compile/T15743e.stderr index 01e20c63b9..8db06cbdcb 100644 --- a/testsuite/tests/dependent/should_compile/T15743e.stderr +++ b/testsuite/tests/dependent/should_compile/T15743e.stderr @@ -54,4 +54,4 @@ DATA CONSTRUCTORS (d :: Proxy k5) (e :: Proxy k7). f c -> T k8 a b f c d e Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/ffi/should_run/T16650a.hs b/testsuite/tests/ffi/should_run/T16650a.hs index ab1cd9c67e..6a43a55118 100644 --- a/testsuite/tests/ffi/should_run/T16650a.hs +++ b/testsuite/tests/ffi/should_run/T16650a.hs @@ -44,4 +44,4 @@ luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of readByteArray :: MutableByteArray -> Int -> IO Word8 readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 -> case readWord8Array# b# i# s0 of - (# s1, w #) -> (# s1, W8# w #) + (# s1, w #) -> (# s1, W8# (narrowWord8# w) #) diff --git a/testsuite/tests/ffi/should_run/T16650b.hs b/testsuite/tests/ffi/should_run/T16650b.hs index 763329fc8b..ba0d4a72a0 100644 --- a/testsuite/tests/ffi/should_run/T16650b.hs +++ b/testsuite/tests/ffi/should_run/T16650b.hs @@ -53,7 +53,7 @@ luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of readByteArray :: MutableByteArray -> Int -> IO Word8 readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 -> case readWord8Array# b# i# s0 of - (# s1, w #) -> (# s1, W8# w #) + (# s1, w #) -> (# s1, W8# (narrowWord8# w) #) -- Write a mutable byte array to the array of mutable byte arrays -- at the given index. diff --git a/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs b/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs index 8e0aaeef50..8953e9b02d 100644 --- a/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs +++ b/testsuite/tests/ffi/should_run/UnliftedNewtypesByteArrayOffset.hs @@ -35,7 +35,7 @@ main = do readByteArray :: MutableByteArray -> Int -> IO Word8 readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 -> case readWord8Array# b# i# s0 of - (# s1, w #) -> (# s1, W8# w #) + (# s1, w #) -> (# s1, W8# (narrowWord8# w) #) -- Create a new mutable byte array of length 1 with the sole byte -- set to the 105. @@ -43,5 +43,3 @@ luckySingleton :: IO MutableByteArray luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of (# s1, marr# #) -> case writeWord8Array# marr# 0# 105## s1 of s2 -> (# s2, MutableByteArray marr# #) - - diff --git a/testsuite/tests/indexed-types/should_compile/T15711.stderr b/testsuite/tests/indexed-types/should_compile/T15711.stderr index 3e5cf86195..7c47eaf82a 100644 --- a/testsuite/tests/indexed-types/should_compile/T15711.stderr +++ b/testsuite/tests/indexed-types/should_compile/T15711.stderr @@ -3,4 +3,4 @@ TYPE CONSTRUCTORS associated type family F{2} :: forall a. Maybe a -> * roles nominal nominal Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/indexed-types/should_compile/T15852.stderr b/testsuite/tests/indexed-types/should_compile/T15852.stderr index 05aef7ca0d..8c212a06b6 100644 --- a/testsuite/tests/indexed-types/should_compile/T15852.stderr +++ b/testsuite/tests/indexed-types/should_compile/T15852.stderr @@ -9,4 +9,4 @@ FAMILY INSTANCES data instance forall {k1} {k2} {j :: k1} {c :: k2}. DF (Proxy c) -- Defined at T15852.hs:10:15 Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/lib/integer/integerImportExport.hs b/testsuite/tests/lib/integer/integerImportExport.hs index bef208afd0..ab044214ed 100644 --- a/testsuite/tests/lib/integer/integerImportExport.hs +++ b/testsuite/tests/lib/integer/integerImportExport.hs @@ -33,13 +33,13 @@ newByteArray :: Word# -> IO MBA newByteArray sz = IO $ \s -> case newPinnedByteArray# (word2Int# sz) s of (# s, arr #) -> (# s, MBA arr #) indexByteArray :: ByteArray# -> Word# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# (word2Int# n#)) +indexByteArray a# n# = W8# (narrowWord8# (indexWord8Array# a# (word2Int# n#))) -- indexMutableByteArray :: MutableByteArray# RealWorld -> Word# -> IO Word8 -- indexMutableByteArray a# n# = IO $ \s -> case readWord8Array# a# (word2Int# n#) s of (# s', v #) -> (# s', W# v #) writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> case writeWord8Array# arr i w s of s -> (# s, () #) +writeByteArray arr i (W8# w) = IO $ \s -> case writeWord8Array# arr i (extendWord8# w) s of s -> (# s, () #) lengthByteArray :: ByteArray# -> Word lengthByteArray ba = W# (int2Word# (sizeofByteArray# ba)) diff --git a/testsuite/tests/numeric/should_compile/T16402.stderr-ws-32 b/testsuite/tests/numeric/should_compile/T16402.stderr-ws-32 new file mode 100644 index 0000000000..726bcc374e --- /dev/null +++ b/testsuite/tests/numeric/should_compile/T16402.stderr-ws-32 @@ -0,0 +1,133 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 124, types: 172, coercions: 0, joins: 0/0} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule3 = TrNameS $trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule2 = "T16402"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule1 = TrNameS $trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$trModule = Module $trModule3 $trModule1 + +-- RHS size: {terms: 18, types: 25, coercions: 0, joins: 0/0} +smallWord_bar + = \ x -> + case x of { W64# x# -> + case {__pkg_ccall ghc-prim Word64# + -> State# RealWorld -> (# State# RealWorld, Word# #)} + x# realWorld# + of + { (# ds1, ds2 #) -> + case {__pkg_ccall ghc-prim Word# + -> State# RealWorld -> (# State# RealWorld, Word64# #)} + (and# ds2 0xffff##) realWorld# + of + { (# ds4, ds5 #) -> + W64# ds5 + } + } + } + +-- RHS size: {terms: 24, types: 36, coercions: 0, joins: 0/0} +smallWord_foo + = \ x -> + case x of { W64# x# -> + case {__pkg_ccall ghc-prim Word64# + -> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)} + x# 0xffff##64 realWorld# + of + { (# ds2, ds3 #) -> + case {__pkg_ccall ghc-prim Word64# + -> State# RealWorld -> (# State# RealWorld, Word# #)} + ds3 realWorld# + of + { (# ds1, ds4 #) -> + case {__pkg_ccall ghc-prim Word# + -> State# RealWorld -> (# State# RealWorld, Word64# #)} + (and# ds4 0xffff##) realWorld# + of + { (# ds5, ds6 #) -> + W64# ds6 + } + } + } + } + +-- RHS size: {terms: 18, types: 25, coercions: 0, joins: 0/0} +smallInt_bar + = \ x -> + case x of { I64# x# -> + case {__pkg_ccall ghc-prim Int64# + -> State# RealWorld -> (# State# RealWorld, Int# #)} + x# realWorld# + of + { (# ds1, ds2 #) -> + case {__pkg_ccall ghc-prim Int# + -> State# RealWorld -> (# State# RealWorld, Int64# #)} + (extendInt16# (narrowInt16# ds2)) realWorld# + of + { (# ds4, ds5 #) -> + I64# ds5 + } + } + } + +-- RHS size: {terms: 35, types: 67, coercions: 0, joins: 0/0} +$wsmallInt_foo + = \ ww -> + case {__pkg_ccall ghc-prim Int64# + -> State# RealWorld -> (# State# RealWorld, Word64# #)} + 1245183#64 realWorld# + of + { (# ds2, ds3 #) -> + case {__pkg_ccall ghc-prim Int64# + -> State# RealWorld -> (# State# RealWorld, Word64# #)} + ww realWorld# + of + { (# ds4, ds5 #) -> + case {__pkg_ccall ghc-prim Word64# + -> Word64# -> State# RealWorld -> (# State# RealWorld, Word64# #)} + ds5 ds3 realWorld# + of + { (# ds6, ds7 #) -> + case {__pkg_ccall ghc-prim Word64# + -> State# RealWorld -> (# State# RealWorld, Int64# #)} + ds7 realWorld# + of + { (# ds8, ds9 #) -> + case {__pkg_ccall ghc-prim Int64# + -> State# RealWorld -> (# State# RealWorld, Int# #)} + ds9 realWorld# + of + { (# ds1, ds11 #) -> + case {__pkg_ccall ghc-prim Int# + -> State# RealWorld -> (# State# RealWorld, Int64# #)} + (extendInt16# (narrowInt16# ds11)) realWorld# + of + { (# ds12, ds13 #) -> + ds13 + } + } + } + } + } + } + +-- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} +smallInt_foo + = \ w -> + case w of { I64# ww1 -> + case $wsmallInt_foo ww1 of ww2 { __DEFAULT -> I64# ww2 } + } + + + diff --git a/testsuite/tests/numeric/should_compile/T16402.stderr b/testsuite/tests/numeric/should_compile/T16402.stderr-ws-64 index 75db843376..d81adaaa7b 100644 --- a/testsuite/tests/numeric/should_compile/T16402.stderr +++ b/testsuite/tests/numeric/should_compile/T16402.stderr-ws-64 @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 34, types: 19, coercions: 0, joins: 0/0} + = {terms: 36, types: 19, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule4 = "main"# @@ -18,16 +18,17 @@ $trModule1 = TrNameS $trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} $trModule = Module $trModule3 $trModule1 --- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} smallWord_bar - = \ x -> case x of { W64# x# -> W64# (narrow16Word# x#) } + = \ x -> case x of { W64# x# -> W64# (and# x# 0xffff##) } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} smallWord_foo = smallWord_bar --- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0} smallInt_bar - = \ x -> case x of { I64# x# -> I64# (narrow16Int# x#) } + = \ x -> + case x of { I64# x# -> I64# (extendInt16# (narrowInt16# x#)) } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} smallInt_foo = smallInt_bar diff --git a/testsuite/tests/parser/should_run/BinaryLiterals2.hs b/testsuite/tests/parser/should_run/BinaryLiterals2.hs index 3779d52341..305a12cab3 100644 --- a/testsuite/tests/parser/should_run/BinaryLiterals2.hs +++ b/testsuite/tests/parser/should_run/BinaryLiterals2.hs @@ -6,6 +6,7 @@ module Main where +import GHC.Base import GHC.Types import GHC.Int @@ -26,4 +27,4 @@ main = do , -0B11111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 ] - print [ I8# -0B10000000#, I8# 0B1111111# ] + print [ I8# (narrowInt8# -0B10000000#), I8# (narrowInt8# 0B1111111#) ] diff --git a/testsuite/tests/polykinds/T15592.stderr b/testsuite/tests/polykinds/T15592.stderr index 5f0334b43b..c0f494f281 100644 --- a/testsuite/tests/polykinds/T15592.stderr +++ b/testsuite/tests/polykinds/T15592.stderr @@ -5,4 +5,4 @@ DATA CONSTRUCTORS MkT :: forall {k} k1 (f :: k1 -> k -> *) (a :: k1) (b :: k). f a b -> T f a b -> T f a b Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/polykinds/T15592b.stderr b/testsuite/tests/polykinds/T15592b.stderr index e2a538f9d8..e64b81cebe 100644 --- a/testsuite/tests/polykinds/T15592b.stderr +++ b/testsuite/tests/polykinds/T15592b.stderr @@ -4,4 +4,4 @@ TYPE CONSTRUCTORS forall k (f :: k -> *) (a :: k). f a -> * roles nominal nominal nominal nominal Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/testsuite/tests/printer/T18052a.stderr b/testsuite/tests/printer/T18052a.stderr index de339de3c4..582a14a32c 100644 --- a/testsuite/tests/printer/T18052a.stderr +++ b/testsuite/tests/printer/T18052a.stderr @@ -6,7 +6,7 @@ TYPE CONSTRUCTORS PATTERN SYNONYMS (:||:) :: forall {a} {b}. a -> b -> (a, b) Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] ==================== Tidy Core ==================== Result size of Tidy Core @@ -36,6 +36,3 @@ T18052a.$m:||: (cont :: a -> b -> r) _ [Occ=Dead] -> case scrut of { (x, y) -> cont x y } - - - diff --git a/testsuite/tests/profiling/should_run/T3001-2.hs b/testsuite/tests/profiling/should_run/T3001-2.hs index 6511491a46..186fd2f2f9 100644 --- a/testsuite/tests/profiling/should_run/T3001-2.hs +++ b/testsuite/tests/profiling/should_run/T3001-2.hs @@ -153,7 +153,7 @@ readN :: Int -> (S.ByteString -> a) -> Get a readN n f = fmap f $ getBytes n shiftl_w32 :: Word32 -> Int -> Word32 -shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (narrowWord32# ((extendWord32# w) `uncheckedShiftL#` i)) getPtr :: Storable a => Int -> Get a getPtr n = do @@ -274,7 +274,7 @@ putWord32beB w = writeN 4 $ \p -> do poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) shiftr_w32 :: Word32 -> Int -> Word32 -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (narrowWord32# ((extendWord32# w) `uncheckedShiftRL#` i)) flush :: Builder flush = Builder $ \ k buf@(Buffer p o u l) -> @@ -291,4 +291,3 @@ instance Semigroup Builder where instance Monoid Builder where mempty = emptyBuilder mappend = (<>) - diff --git a/testsuite/tests/simplCore/should_compile/T5359a.hs b/testsuite/tests/simplCore/should_compile/T5359a.hs index ebe85ba4a0..8c4a0beaf7 100644 --- a/testsuite/tests/simplCore/should_compile/T5359a.hs +++ b/testsuite/tests/simplCore/should_compile/T5359a.hs @@ -61,7 +61,7 @@ textP arr off len | len == 0 = emptyT {-# INLINE textP #-} unsafeChrT :: Word16 -> Char -unsafeChrT (W16# w#) = C# (chr# (word2Int# w#)) +unsafeChrT (W16# w#) = C# (chr# (word2Int# (extendWord16# w#))) {-# INLINE unsafeChrT #-} data Array = Array ByteArray# @@ -82,7 +82,7 @@ unsafeFreeze (MArray maBA) = ST $ \s# -> (# s#, Array (unsafeCoerce# maBA) #) unsafeIndex :: Array -> Int -> Word16 unsafeIndex (Array aBA) (I# i#) = - case indexWord16Array# aBA i# of r# -> (W16# r#) + case indexWord16Array# aBA i# of r# -> (W16# (narrowWord16# r#)) {-# INLINE unsafeIndex #-} empty :: Array diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout b/testsuite/tests/simplCore/should_compile/T8832.stdout deleted file mode 100644 index 3e23710089..0000000000 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout +++ /dev/null @@ -1,11 +0,0 @@ -i = GHC.Types.I# 0# -i8 = GHC.Int.I8# 0# -i16 = GHC.Int.I16# 0# -i32 = GHC.Int.I32# 0# -i64 = GHC.Int.I64# 0# -w = GHC.Types.W# 0## -w8 = GHC.Word.W8# 0## -w16 = GHC.Word.W16# 0## -w32 = GHC.Word.W32# 0## -w64 = GHC.Word.W64# 0## -z = 0 diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 index 3186412561..459d2689c7 100644 --- a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-32 @@ -1,9 +1,9 @@ i = GHC.Types.I# 0# -i8 = GHC.Int.I8# 0# -i16 = GHC.Int.I16# 0# -i32 = GHC.Int.I32# 0# +i8 = GHC.Int.I8# 0#8 +i16 = GHC.Int.I16# 0#16 +i32 = GHC.Int.I32# 0#32 w = GHC.Types.W# 0## -w8 = GHC.Word.W8# 0## -w16 = GHC.Word.W16# 0## -w32 = GHC.Word.W32# 0## +w8 = GHC.Word.W8# 0##8 +w16 = GHC.Word.W16# 0##16 +w32 = GHC.Word.W32# 0##32 z = 0 diff --git a/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 new file mode 100644 index 0000000000..657f517c68 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T8832.stdout-ws-64 @@ -0,0 +1,11 @@ +i = GHC.Types.I# 0# +i8 = GHC.Int.I8# 0#8 +i16 = GHC.Int.I16# 0#16 +i32 = GHC.Int.I32# 0#32 +i64 = GHC.Int.I64# 0# +w = GHC.Types.W# 0## +w8 = GHC.Word.W8# 0##8 +w16 = GHC.Word.W16# 0##16 +w32 = GHC.Word.W32# 0##32 +w64 = GHC.Word.W64# 0## +z = 0 diff --git a/testsuite/tests/typecheck/should_compile/T12763.stderr b/testsuite/tests/typecheck/should_compile/T12763.stderr index 552fd5f1d2..2496d16dcd 100644 --- a/testsuite/tests/typecheck/should_compile/T12763.stderr +++ b/testsuite/tests/typecheck/should_compile/T12763.stderr @@ -8,4 +8,4 @@ COERCION AXIOMS CLASS INSTANCES instance C Int -- Defined at T12763.hs:9:10 Dependent modules: [] -Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.7.0] +Dependent packages: [base-4.16.0.0, ghc-bignum-1.0, ghc-prim-0.8.0] diff --git a/utils/haddock b/utils/haddock -Subproject 25fa8fde84701c010fa466c2648f8f6d10265e8 +Subproject 2d06af2fc535dacc4bac45d45e8eb95a7620caa |