From 5861bb81decb29ad398c3586f0bba0a1e872ff67 Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 7 Dec 2001 11:34:48 +0000 Subject: [PATCH] [project @ 2001-12-07 11:34:48 by sewardj] Change the story on shifting primops: SllOp, SrlOp, ISllOp, ISraOp, ISrlOp. In the old primop story, these were implemented by C macros which checked that the shift amount did not exceed the word size, and if so returns a suitable value (0 or -1). This gives consistent, defined behaviour for any shift amount. However, these checks were not implemented on the NCG route, an inconsistency. New story: these primops do NOT check their args; they just do the shift. Shift values >= word size give undefined results. To reflect this, their Haskell names have been prefixed with 'unchecked'. The checks are now done on the Bits instances in the Prelude. This means all code generation routes are consistently checked, and hopefully the simplifier will remove the checks for literal shift amounts. I have tried to fix up the implementation for 64-bit platforms too, but not having one to hand, I don't know if it will work as-is. --- ghc/compiler/prelude/primops.txt.pp | 27 ++++++----- ghc/includes/PrimOps.h | 12 ++--- ghc/lib/std/PrelBase.lhs | 14 +++--- ghc/lib/std/PrelBits.lhs | 20 ++++++--- ghc/lib/std/PrelGHC.hi-boot.pp | 10 ++--- ghc/lib/std/PrelInt.lhs | 82 ++++++++++++++++++++------------- ghc/lib/std/PrelWord.lhs | 85 +++++++++++++++++++++-------------- ghc/lib/std/cbits/longlong.c | 15 ++++--- 8 files changed, 157 insertions(+), 108 deletions(-) diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index a8a80db..8d12268 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.10 2001/12/05 17:35:14 sewardj Exp $ +-- $Id: primops.txt.pp,v 1.11 2001/12/07 11:34:48 sewardj Exp $ -- -- Primitive Operations -- @@ -226,12 +226,15 @@ primop Int2IntegerOp "int2Integer#" GenPrimOp Int# -> (# Int#, ByteArr# #) with out_of_line = True -primop ISllOp "iShiftL#" GenPrimOp Int# -> Int# -> Int# - {Shift left. Return 0 if shifted by more than size of an Int\#.} -primop ISraOp "iShiftRA#" GenPrimOp Int# -> Int# -> Int# - {Shift right arithemetic. Return 0 if shifted by more than size of an Int\#.} -primop ISrlOp "iShiftRL#" GenPrimOp Int# -> Int# -> Int# - {Shift right logical. Return 0 if shifted by more than size of an Int\#.} +primop ISllOp "uncheckedIShiftL#" GenPrimOp Int# -> Int# -> Int# + {Shift left. Result undefined if shift amount equals + or exceeds word size.} +primop ISraOp "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int# + {Shift right arithmetic. Result undefined if shift amount equals + or exceeds word size.} +primop ISrlOp "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int# + {Shift right logical. Result undefined if shift amount equals + or exceeds word size.} ------------------------------------------------------------------------ section "Word#" @@ -263,10 +266,12 @@ primop XorOp "xor#" Dyadic Word# -> Word# -> Word# primop NotOp "not#" Monadic Word# -> Word# -primop SllOp "shiftL#" GenPrimOp Word# -> Int# -> Word# - {Shift left logical. Return 0 if shifted by more than number of bits in a Word\#.} -primop SrlOp "shiftRL#" GenPrimOp Word# -> Int# -> Word# - {Shift right logical. Return 0 if shifted by more than number of bits in a Word\#.} +primop SllOp "uncheckedShiftL#" GenPrimOp Word# -> Int# -> Word# + {Shift left logical. Result undefined if shift amount equals + or exceeds word size.} +primop SrlOp "uncheckedShiftRL#" GenPrimOp Word# -> Int# -> Word# + {Shift right logical. Result undefined if shift amount equals + or exceeds word size.} primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index e48f54b..55ef777 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.86 2001/12/05 17:35:14 sewardj Exp $ + * $Id: PrimOps.h,v 1.87 2001/12/07 11:34:48 sewardj Exp $ * * (c) The GHC Team, 1998-2000 * @@ -210,11 +210,11 @@ LW_ stg_or64 (StgWord64, StgWord64); LW_ stg_xor64 (StgWord64, StgWord64); LW_ stg_not64 (StgWord64); -LW_ stg_shiftL64 (StgWord64, StgInt); -LW_ stg_shiftRL64 (StgWord64, StgInt); -LI_ stg_iShiftL64 (StgInt64, StgInt); -LI_ stg_iShiftRL64 (StgInt64, StgInt); -LI_ stg_iShiftRA64 (StgInt64, StgInt); +LW_ stg_uncheckedShiftL64 (StgWord64, StgInt); +LW_ stg_uncheckedShiftRL64 (StgWord64, StgInt); +LI_ stg_uncheckedIShiftL64 (StgInt64, StgInt); +LI_ stg_uncheckedIShiftRL64 (StgInt64, StgInt); +LI_ stg_uncheckedIShiftRA64 (StgInt64, StgInt); LI_ stg_intToInt64 (StgInt); I_ stg_int64ToInt (StgInt64); diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs index b74da36..5ff8a80 100644 --- a/ghc/lib/std/PrelBase.lhs +++ b/ghc/lib/std/PrelBase.lhs @@ -1,5 +1,5 @@ % ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.55 2001/10/17 15:40:02 simonpj Exp $ +% $Id: PrelBase.lhs,v 1.56 2001/12/07 11:34:48 sewardj Exp $ % % (c) The University of Glasgow, 1992-2000 % @@ -746,18 +746,18 @@ unpackCStringUtf8# addr | ch `eqChar#` '\0'# = [] | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) | ch `leChar#` '\xDF'# = - C# (chr# ((ord# ch -# 0xC0#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : unpack (nh +# 2#) | ch `leChar#` '\xEF'# = - C# (chr# ((ord# ch -# 0xE0#) `iShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12# +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : unpack (nh +# 3#) | otherwise = - C# (chr# ((ord# ch -# 0xF0#) `iShiftL#` 18# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `iShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `iShiftL#` 6# +# + C# (chr# ((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18# +# + (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +# + (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6# +# (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : unpack (nh +# 4#) where diff --git a/ghc/lib/std/PrelBits.lhs b/ghc/lib/std/PrelBits.lhs index 68b496f..594eb56 100644 --- a/ghc/lib/std/PrelBits.lhs +++ b/ghc/lib/std/PrelBits.lhs @@ -61,15 +61,21 @@ instance Bits Int where (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I# x#) `shift` (I# i#) - | i# >=# 0# = I# (x# `iShiftL#` i#) - | otherwise = I# (x# `iShiftRA#` negateInt# i#) + | i# ==# 0# = I# x# + | i# >=# wsib = 0 + | i# ># 0# = I# (x# `uncheckedIShiftL#` i#) + | i# <=# nwsib = I# (if x# <# 0# then -1# else 0#) + | otherwise = I# (x# `uncheckedIShiftRA#` negateInt# i#) + where + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + nwsib = negateInt# wsib (I# x#) `rotate` (I# i#) = - I# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (wsib -# i'#)))) + I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (wsib -# i'#)))) where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + x'# = int2Word# x# + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# bitSize _ = WORD_SIZE_IN_BITS isSigned _ = True \end{code} diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp index d9ae781..2a8953a 100644 --- a/ghc/lib/std/PrelGHC.hi-boot.pp +++ b/ghc/lib/std/PrelGHC.hi-boot.pp @@ -90,9 +90,9 @@ __export PrelGHC remIntzh gcdIntzh negateIntzh - iShiftLzh - iShiftRAzh - iShiftRLzh + uncheckedIShiftLzh + uncheckedIShiftRAzh + uncheckedIShiftRLzh addIntCzh subIntCzh mulIntCzh @@ -113,8 +113,8 @@ __export PrelGHC orzh notzh xorzh - shiftLzh - shiftRLzh + uncheckedShiftLzh + uncheckedShiftRLzh int2Wordzh word2Intzh diff --git a/ghc/lib/std/PrelInt.lhs b/ghc/lib/std/PrelInt.lhs index 13f7c4a..83f1c63 100644 --- a/ghc/lib/std/PrelInt.lhs +++ b/ghc/lib/std/PrelInt.lhs @@ -110,14 +110,17 @@ instance Bits Int8 where (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I8# x#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I8# x#) `shift` (I# i#) - | i# >=# 0# = I8# (narrow8Int# (x# `iShiftL#` i#)) - | otherwise = I8# (x# `iShiftRA#` negateInt# i#) + | i# ==# 0# = I8# x# + | i# >=# 8# = I8# 0# + | i# ># 0# = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#)) + | i# <=# -8# = I8# (if x# <# 0# then -1# else 0#) + | otherwise = I8# (x# `uncheckedIShiftRA#` negateInt# i#) (I8# x#) `rotate` (I# i#) | i'# ==# 0# = I8# x# | otherwise - = I8# (narrow8Int# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (8# -# i'#))))) + = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (8# -# i'#))))) where x'# = narrow8Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) @@ -218,14 +221,17 @@ instance Bits Int16 where (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I16# x#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I16# x#) `shift` (I# i#) - | i# >=# 0# = I16# (narrow16Int# (x# `iShiftL#` i#)) - | otherwise = I16# (x# `iShiftRA#` negateInt# i#) + | i# ==# 0# = I16# x# + | i# >=# 16# = I16# 0# + | i# ># 0# = I16# (narrow16Int# (x# `uncheckedIShiftL#` i#)) + | i# <=# -16# = I16# (if x# <# 0# then -1# else 0#) + | otherwise = I16# (x# `uncheckedIShiftRA#` negateInt# i#) (I16# x#) `rotate` (I# i#) | i'# ==# 0# = I16# x# | otherwise - = I16# (narrow16Int# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (16# -# i'#))))) + = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (16# -# i'#))))) where x'# = narrow16Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) @@ -339,14 +345,17 @@ instance Bits Int32 where (I32# x#) `xor` (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#)) complement (I32# x#) = I32# (word32ToInt32# (not32# (int32ToWord32# x#))) (I32# x#) `shift` (I# i#) - | i# >=# 0# = I32# (x# `iShiftL32#` i#) - | otherwise = I32# (x# `iShiftRA32#` negateInt# i#) + | i# ==# 0# = I32# x# + | i# >=# 32# = I32# 0# + | i# ># 0# = I32# (x# `uncheckedIShiftL32#` i#) + | i# <=# -32# = I32# (if x# <# 0# then -1# else 0#) + | otherwise = I32# (x# `uncheckedIShiftRA32#` negateInt# i#) (I32# x#) `rotate` (I# i#) | i'# ==# 0# = I32# x# | otherwise - = I32# (word32ToInt32# ((x'# `shiftL32#` i'#) `or32#` - (x'# `shiftRL32#` (32# -# i'#)))) + = I32# (word32ToInt32# ((x'# `uncheckedShiftL32#` i'#) `or32#` + (x'# `uncheckedShiftRL32#` (32# -# i'#)))) where x'# = int32ToWord32# x# i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) @@ -374,10 +383,10 @@ foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# - foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# -foreign import "stg_iShiftL32" unsafe iShiftL32# :: Int32# -> Int# -> Int32# -foreign import "stg_iShiftRA32" unsafe iShiftRA32# :: Int32# -> Int# -> Int32# -foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# -foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# +foreign import "stg_uncheckedIShiftL32" unsafe uncheckedIShiftL32# :: Int32# -> Int# -> Int32# +foreign import "stg_uncheckedIShiftRA32" unsafe uncheckedIShiftRA32# :: Int32# -> Int# -> Int32# +foreign import "stg_uncheckedShiftL32" unsafe uncheckedShiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_uncheckedShiftRL32" unsafe uncheckedShiftRL32# :: Word32# -> Int# -> Word32# {-# RULES "fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) @@ -466,14 +475,17 @@ instance Bits Int32 where (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I32# x#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I32# x#) `shift` (I# i#) - | i# >=# 0# = I32# (narrow32Int# (x# `iShiftL#` i#)) - | otherwise = I32# (x# `iShiftRA#` negateInt# i#) + | i# ==# 0# = I32# x# + | i# >=# 32# = I32# 0# + | i# ># 0# = I32# (narrow32Int# (x# `uncheckedIShiftL#` i#)) + | i# <=# -32# = I32# (if x# <# 0# then -1# else 0#) + | otherwise = I32# (x# `uncheckedIShiftRA#` negateInt# i#) (I32# x#) `rotate` (I# i#) | i'# ==# 0# = I32# x# | otherwise - = I32# (narrow32Int# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (32# -# i'#))))) + = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (32# -# i'#))))) where x'# = narrow32Word# (int2Word# x#) i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) @@ -608,14 +620,17 @@ instance Bits Int64 where (I64# x#) `xor` (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#)) complement (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#))) (I64# x#) `shift` (I# i#) - | i# >=# 0# = I64# (x# `iShiftL64#` i#) - | otherwise = I64# (x# `iShiftRA64#` negateInt# i#) + | i# ==# 0# = I64# x# + | i# >=# 64# = 0 + | i# ># 0# = I64# (x# `uncheckedIShiftL64#` i#) + | i# <=# -64# = if (I64# x#) < 0 then -1 else 0 + | otherwise = I64# (x# `uncheckedIShiftRA64#` negateInt# i#) (I64# x#) `rotate` (I# i#) | i'# ==# 0# = I64# x# | otherwise - = I64# (word64ToInt64# ((x'# `shiftL64#` i'#) `or64#` - (x'# `shiftRL64#` (64# -# i'#)))) + = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#` + (x'# `uncheckedShiftRL64#` (64# -# i'#)))) where x'# = int64ToWord64# x# i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) @@ -643,10 +658,10 @@ foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# - foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# -foreign import "stg_iShiftL64" unsafe iShiftL64# :: Int64# -> Int# -> Int64# -foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> Int64# -foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# -foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_uncheckedIShiftL64" unsafe uncheckedIShiftL64# :: Int64# -> Int# -> Int64# +foreign import "stg_uncheckedIShiftRA64" unsafe uncheckedIShiftRA64# :: Int64# -> Int# -> Int64# +foreign import "stg_uncheckedShiftL64" unsafe uncheckedShiftL64# :: Word64# -> Int# -> Word64# +foreign import "stg_uncheckedShiftRL64" unsafe uncheckedShiftRL64# :: Word64# -> Int# -> Word64# foreign import "stg_integerToInt64" unsafe integerToInt64# :: Int# -> ByteArray# -> Int64# @@ -726,14 +741,17 @@ instance Bits Int64 where (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#)) complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) (I64# x#) `shift` (I# i#) - | i# >=# 0# = I64# (x# `iShiftL#` i#) - | otherwise = I64# (x# `iShiftRA#` negateInt# i#) + | i# ==# 0# = I64# x# + | i# >=# 64# = 0 + | i# ># 0# = I64# (x# `uncheckedIShiftL#` i#) + | i# <=# -64# = if x# <# 0# then -1 else 0 + | otherwise = I64# (x# `uncheckedIShiftRA#` negateInt# i#) (I64# x#) `rotate` (I# i#) | i'# ==# 0# = I64# x# | otherwise - = I64# (word2Int# ((x'# `shiftL#` i'#) `or#` - (x'# `shiftRL#` (64# -# i'#)))) + = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` + (x'# `uncheckedShiftRL#` (64# -# i'#)))) where x'# = int2Word# x# i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) diff --git a/ghc/lib/std/PrelWord.lhs b/ghc/lib/std/PrelWord.lhs index 30af9fc..811cf3d 100644 --- a/ghc/lib/std/PrelWord.lhs +++ b/ghc/lib/std/PrelWord.lhs @@ -154,14 +154,21 @@ instance Bits Word where (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) complement (W# x#) = W# (x# `xor#` mb#) where W# mb# = maxBound (W# x#) `shift` (I# i#) - | i# >=# 0# = W# (x# `shiftL#` i#) - | otherwise = W# (x# `shiftRL#` negateInt# i#) + | i# ==# 0# = W# x# + | i# >=# wsib = W# (int2Word# 0#) + | i# ># 0# = W# (x# `uncheckedShiftL#` i#) + | i# <=# nwsib = W# (int2Word# 0#) + | otherwise = W# (x# `uncheckedShiftRL#` negateInt# i#) + where + wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + nwsib = negateInt# wsib (W# x#) `rotate` (I# i#) | i'# ==# 0# = W# x# - | otherwise = W# ((x# `shiftL#` i'#) `or#` (x# `shiftRL#` (wsib -# i'#))) + | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (wsib -# i'#))) where - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} + i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) + wsib = WORD_SIZE_IN_BITS# bitSize _ = WORD_SIZE_IN_BITS isSigned _ = False @@ -255,12 +262,14 @@ instance Bits Word8 where (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound (W8# x#) `shift` (I# i#) - | i# >=# 0# = W8# (narrow8Word# (x# `shiftL#` i#)) - | otherwise = W8# (x# `shiftRL#` negateInt# i#) + | i# ==# 0# = W8# x# + | i# >=# 8# || i# <=# -8# = W8# (int2Word# 0#) + | i# ># 0# = W8# (narrow8Word# (x# `uncheckedShiftL#` i#)) + | otherwise = W8# (x# `uncheckedShiftRL#` negateInt# i#) (W8# x#) `rotate` (I# i#) | i'# ==# 0# = W8# x# - | otherwise = W8# (narrow8Word# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (8# -# i'#)))) + | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (8# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) bitSize _ = 8 @@ -357,12 +366,14 @@ instance Bits Word16 where (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound (W16# x#) `shift` (I# i#) - | i# >=# 0# = W16# (narrow16Word# (x# `shiftL#` i#)) - | otherwise = W16# (x# `shiftRL#` negateInt# i#) + | i# ==# 0# = W16# x# + | i# >=# 16# || i# <=# -16# = W16# (int2Word# 0#) + | i# ># 0# = W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) + | otherwise = W16# (x# `uncheckedShiftRL#` negateInt# i#) (W16# x#) `rotate` (I# i#) | i'# ==# 0# = W16# x# - | otherwise = W16# (narrow16Word# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (16# -# i'#)))) + | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (16# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) bitSize _ = 16 @@ -453,12 +464,14 @@ instance Bits Word32 where (W32# x#) `xor` (W32# y#) = W32# (x# `xor32#` y#) complement (W32# x#) = W32# (not32# x#) (W32# x#) `shift` (I# i#) - | i# >=# 0# = W32# (x# `shiftL32#` i#) - | otherwise = W32# (x# `shiftRL32#` negateInt# i#) + | i# ==# 0# = W32# x# + | i# >=# 32# || i# <=# -32# = W32# (int2Word# 0#) + | i# ># 0# = W32# (x# `uncheckedShiftL32#` i#) + | otherwise = W32# (x# `uncheckedShiftRL32#` negateInt# i#) (W32# x#) `rotate` (I# i#) | i'# ==# 0# = W32# x# - | otherwise = W32# ((x# `shiftL32#` i'#) `or32#` - (x# `shiftRL32#` (32# -# i'#))) + | otherwise = W32# ((x# `uncheckedShiftL32#` i'#) `or32#` + (x# `uncheckedShiftRL32#` (32# -# i'#))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 @@ -485,8 +498,8 @@ foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# - foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# -foreign import "stg_shiftL32" unsafe shiftL32# :: Word32# -> Int# -> Word32# -foreign import "stg_shiftRL32" unsafe shiftRL32# :: Word32# -> Int# -> Word32# +foreign import "stg_uncheckedShiftL32" unsafe uncheckedShiftL32# :: Word32# -> Int# -> Word32# +foreign import "stg_uncheckedShiftRL32" unsafe uncheckedShiftRL32# :: Word32# -> Int# -> Word32# {-# RULES "fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) @@ -581,12 +594,14 @@ instance Bits Word32 where (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound (W32# x#) `shift` (I# i#) - | i# >=# 0# = W32# (narrow32Word# (x# `shiftL#` i#)) - | otherwise = W32# (x# `shiftRL#` negateInt# i#) + | i# ==# 0# = W32# x# + | i# >=# 32# || i# <=# -32# = W32# (int2Word# 0#) + | i# ># 0# = W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) + | otherwise = W32# (x# `uncheckedShiftRL#` negateInt# i#) (W32# x#) `rotate` (I# i#) | i'# ==# 0# = W32# x# - | otherwise = W32# (narrow32Word# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (32# -# i'#)))) + | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (32# -# i'#)))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) bitSize _ = 32 @@ -711,12 +726,14 @@ instance Bits Word64 where (W64# x#) `xor` (W64# y#) = W64# (x# `xor64#` y#) complement (W64# x#) = W64# (not64# x#) (W64# x#) `shift` (I# i#) - | i# >=# 0# = W64# (x# `shiftL64#` i#) - | otherwise = W64# (x# `shiftRL64#` negateInt# i#) + | i# ==# 0# = W64# x# + | i# >=# 64# || i# <=# -64# = 0 + | i# ># 0# = W64# (x# `uncheckedShiftL64#` i#) + | otherwise = W64# (x# `uncheckedShiftRL64#` negateInt# i#) (W64# x#) `rotate` (I# i#) | i'# ==# 0# = W64# x# - | otherwise = W64# ((x# `shiftL64#` i'#) `or64#` - (x# `shiftRL64#` (64# -# i'#))) + | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#` + (x# `uncheckedShiftRL64#` (64# -# i'#))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 @@ -743,8 +760,8 @@ foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# - foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# -foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64# -foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64# +foreign import "stg_uncheckedShiftL64" unsafe uncheckedShiftL64# :: Word64# -> Int# -> Word64# +foreign import "stg_uncheckedShiftRL64" unsafe uncheckedShiftRL64# :: Word64# -> Int# -> Word64# foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64# @@ -826,12 +843,14 @@ instance Bits Word64 where (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) complement (W64# x#) = W64# (x# `xor#` mb#) where W64# mb# = maxBound (W64# x#) `shift` (I# i#) - | i# >=# 0# = W64# (x# `shiftL#` i#) - | otherwise = W64# (x# `shiftRL#` negateInt# i#) + | i# ==# 0# = W64# x# + | i# >=# 64# || i# <=# -64# = 0 + | i# ># 0# = W64# (x# `uncheckedShiftL#` i#) + | otherwise = W64# (x# `uncheckedShiftRL#` negateInt# i#) (W64# x#) `rotate` (I# i#) | i'# ==# 0# = W64# x# - | otherwise = W64# ((x# `shiftL#` i'#) `or#` - (x# `shiftRL#` (64# -# i'#))) + | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#` + (x# `uncheckedShiftRL#` (64# -# i'#))) where i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) bitSize _ = 64 diff --git a/ghc/lib/std/cbits/longlong.c b/ghc/lib/std/cbits/longlong.c index fdc7603..a373786 100644 --- a/ghc/lib/std/cbits/longlong.c +++ b/ghc/lib/std/cbits/longlong.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.4 2001/12/05 17:35:15 sewardj Exp $ + * $Id: longlong.c,v 1.5 2001/12/07 11:34:48 sewardj Exp $ * * (c) The GHC Team, 1998-1999 * @@ -63,16 +63,17 @@ StgWord64 stg_and64 (StgWord64 a, StgWord64 b) {return a & b;} StgWord64 stg_or64 (StgWord64 a, StgWord64 b) {return a | b;} StgWord64 stg_xor64 (StgWord64 a, StgWord64 b) {return a ^ b;} StgWord64 stg_not64 (StgWord64 a) {return ~a;} -StgWord64 stg_shiftL64 (StgWord64 a, StgInt b) {return a << b;} -StgWord64 stg_shiftRL64 (StgWord64 a, StgInt b) {return a >> b;} + +StgWord64 stg_uncheckedShiftL64 (StgWord64 a, StgInt b) {return a << b;} +StgWord64 stg_uncheckedShiftRL64 (StgWord64 a, StgInt b) {return a >> b;} /* Right shifting of signed quantities is not portable in C, so the behaviour you'll get from using these primops depends on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98 */ -StgInt64 stg_iShiftL64 (StgInt64 a, StgInt b) {return a << b;} -StgInt64 stg_iShiftRA64 (StgInt64 a, StgInt b) {return a >> b;} -StgInt64 stg_iShiftRL64 (StgInt64 a, StgInt b) -{return (StgInt64) ((StgWord64) a >> b);} +StgInt64 stg_uncheckedIShiftL64 (StgInt64 a, StgInt b) {return a << b;} +StgInt64 stg_uncheckedIShiftRA64 (StgInt64 a, StgInt b) {return a >> b;} +StgInt64 stg_uncheckedIShiftRL64 (StgInt64 a, StgInt b) + {return (StgInt64) ((StgWord64) a >> b);} /* Casting between longs and longer longs. (the primops that cast from long longs to Integers -- 1.7.10.4