diff options
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 |