{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} module Ivory.Language.Bits where import Ivory.Language.Cast import Ivory.Language.IBool import Ivory.Language.Sint import Ivory.Language.Type import Ivory.Language.Uint import Ivory.Language.IIntegral import Data.Word() import qualified Ivory.Language.Syntax as AST -- XXX do not export bitOp :: forall a. IvoryExpr a => AST.ExpOp -> a -> a -> a bitOp op a b = wrapExpr (AST.ExpOp op [unwrapExpr a, unwrapExpr b]) class (Num a, IvoryExpr a) => IvoryBits a where (.&) :: a -> a -> a (.&) = bitOp AST.ExpBitAnd (.|) :: a -> a -> a (.|) = bitOp AST.ExpBitOr (.^) :: a -> a -> a (.^) = bitOp AST.ExpBitXor iComplement :: a -> a iComplement a = wrapExpr (AST.ExpOp AST.ExpBitComplement [unwrapExpr a]) iBitSize :: a -> Int -- XXX what should the type of the shift count argument be? having -- it be polymorphic is kind of a pain. for now, just have it be -- the same type as the value being shifted. iShiftL :: a -> a -> a iShiftL = bitOp AST.ExpBitShiftL iShiftR :: a -> a -> a iShiftR = bitOp AST.ExpBitShiftR instance IvoryBits Uint8 where iBitSize _ = 8 instance IvoryBits Uint16 where iBitSize _ = 16 instance IvoryBits Uint32 where iBitSize _ = 32 instance IvoryBits Uint64 where iBitSize _ = 64 -- | Extraction of the upper or lower half of a bit type into the next -- smallest bit type. class (IvoryBits a, IvoryBits b) => BitSplit a b | a -> b where ubits :: a -> b lbits :: a -> b instance BitSplit Uint64 Uint32 where ubits x = ivoryCast ((x `iShiftR` 32) .& 0xffffffff) lbits x = ivoryCast (x .& 0xffffffff) instance BitSplit Uint32 Uint16 where ubits x = ivoryCast ((x `iShiftR` 16) .& 0xffff) lbits x = ivoryCast (x .& 0xffff) instance BitSplit Uint16 Uint8 where ubits x = ivoryCast ((x `iShiftR` 8) .& 0xff) lbits x = ivoryCast (x .& 0xff) -- | A narrowing cast from one bit type to another. This explicitly -- discards the upper bits of the input value to return a smaller -- type, and is only defined for unsigned integers. class (IvoryBits a, IvoryBits b) => BitCast a b where bitCast :: a -> b -- Uint64: instance BitCast Uint64 Uint64 where bitCast = id instance BitCast Uint64 Uint32 where bitCast = lbits instance BitCast Uint64 Uint16 where bitCast = lbits . lbits instance BitCast Uint64 Uint8 where bitCast = lbits . lbits . lbits -- Uint32: instance BitCast Uint32 Uint32 where bitCast = id instance BitCast Uint32 Uint16 where bitCast = lbits instance BitCast Uint32 Uint8 where bitCast = lbits . lbits -- Uint16: instance BitCast Uint16 Uint16 where bitCast = id instance BitCast Uint16 Uint8 where bitCast = lbits -- Uint8: instance BitCast Uint8 Uint8 where bitCast = id -- | Re-interpret the bits of an unsigned integer as though they were a -- signed number in two's complement representation. class ( IvoryBits unsigned , IvoryEq unsigned , IvoryExpr signed , Num signed , IvoryIntegral unsigned , Bounded unsigned , Bounded signed , IvoryOrd signed ) => TwosComplementCast unsigned signed | signed -> unsigned, unsigned -> signed where -- The C standard makes conversion from unsigned to signed -- well-defined as long as the value can be preserved. But if the -- unsigned value is bigger than the largest representable value of -- the signed type, as is the case for a value we want to treat as -- negative, the behavior is implementation-specific, and may trap. -- -- This algorithm checks the most significant bit, which is the sign -- bit. If it is clear, then the value is representable in the target -- type (assuming they're the same bit-width) and we can just cast. -- -- One way to define two's complement is that -x = ~x + 1. Negating -- both sides gives x = -~x - 1, and that is the identity we use when -- the sign bit is set. -- -- If the sign bit was set, then if we flip every bit we will have a -- value that is representable and we can cast it to the target type. -- So we insert the cast after complementing the value but before -- negating and subtracting 1. -- -- On machines that natively use two's complement for signed numbers, -- this should optimize away to use zero instructions. However, the C -- standard also permits implementations that use one's complement or -- sign-magnitude representations, and this algorithm is expected to -- work in those implementations as well. twosComplementCast :: unsigned -> signed twosComplementCast v = ((v `iShiftR` n) ==? 1) ? ( negate (ivoryCast (iComplement v)) - 1 , ivoryCast v) where n = fromIntegral (iBitSize v - 1) -- Takes a signed value interpreted as a two's complement, and returns an -- unsigned value with the identity bit pattern. For the instances below, this -- is guaranteed not to overflow. twosComplementRep :: signed -> unsigned twosComplementRep v = (v <? 0) ? ( m - (s1 - 1) , ivoryCast v ) where m :: unsigned m = maxBound :: unsigned -- v is negative when s1 is used. If v == minBound, then (-v) overflows the -- signed type. So we find maxBound of the signed type within the unsigned -- type with maxBound / 2 + 1 (e.g., 255/2+1 == 128 for int8_t and uint8_t). s1 :: unsigned s1 = (v ==? minBound) ? (maxBound `iDiv` 2 + 1, ivoryCast $ negate v) -- Instances *must* have the same bit-width. instance TwosComplementCast Uint8 Sint8 instance TwosComplementCast Uint16 Sint16 instance TwosComplementCast Uint32 Sint32 instance TwosComplementCast Uint64 Sint64 -- | Extract the least significant byte from an integer. This returns -- the two values (x & 0xFF, x >> 8), with the first value safely -- casted to an 8-bit integer. -- -- This is convenient to use with a state monad and "sets", such as: -- -- > fst $ runState x $ do -- > a <- sets extractByte -- > b <- sets extractByte -- > return (a, b) extractByte :: (BitCast a Uint8) => a -> (Uint8, a) extractByte x = (bitCast x, x `iShiftR` 8)