{-# 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
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
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
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)
class (IvoryBits a, IvoryBits b) => BitCast a b where
bitCast :: a -> b
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
instance BitCast Uint32 Uint32 where
bitCast = id
instance BitCast Uint32 Uint16 where
bitCast = lbits
instance BitCast Uint32 Uint8 where
bitCast = lbits . lbits
instance BitCast Uint16 Uint16 where
bitCast = id
instance BitCast Uint16 Uint8 where
bitCast = lbits
instance BitCast Uint8 Uint8 where
bitCast = id
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
twosComplementCast :: unsigned -> signed
twosComplementCast v = ((v `iShiftR` n) ==? 1) ?
( negate (ivoryCast (iComplement v)) - 1
, ivoryCast v)
where
n = fromIntegral (iBitSize v - 1)
twosComplementRep :: signed -> unsigned
twosComplementRep v = (v <? 0) ?
( m - (s1 - 1)
, ivoryCast v
)
where
m :: unsigned
m = maxBound :: unsigned
s1 :: unsigned
s1 = (v ==? minBound) ? (maxBound `iDiv` 2 + 1, ivoryCast $ negate v)
instance TwosComplementCast Uint8 Sint8
instance TwosComplementCast Uint16 Sint16
instance TwosComplementCast Uint32 Sint32
instance TwosComplementCast Uint64 Sint64
extractByte :: (BitCast a Uint8) => a -> (Uint8, a)
extractByte x = (bitCast x, x `iShiftR` 8)