{-|
Copyright  :  (C) 2018, Google Inc.
License    :  BSD2 (see the file LICENSE)
Maintainer :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

module Clash.Annotations.BitRepresentation.Util
  ( bitOrigins
  , bitOrigins'
  , bitRanges
  , isContinuousMask
  , BitOrigin(..)
  , Bit(..)
  ) where


import Clash.Annotations.BitRepresentation.Internal
  (DataRepr'(..), ConstrRepr'(..))
import Data.Bits  (Bits, testBit, testBit, shiftR, (.|.))
import Data.List  (findIndex, group, mapAccumL)
import Data.Tuple (swap)

data Bit
  -- | High
  = H
  -- | Low
  | L
  -- | Undefined
  | U
    deriving (Int -> Bit -> ShowS
[Bit] -> ShowS
Bit -> String
(Int -> Bit -> ShowS)
-> (Bit -> String) -> ([Bit] -> ShowS) -> Show Bit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bit] -> ShowS
$cshowList :: [Bit] -> ShowS
show :: Bit -> String
$cshow :: Bit -> String
showsPrec :: Int -> Bit -> ShowS
$cshowsPrec :: Int -> Bit -> ShowS
Show,Bit -> Bit -> Bool
(Bit -> Bit -> Bool) -> (Bit -> Bit -> Bool) -> Eq Bit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bit -> Bit -> Bool
$c/= :: Bit -> Bit -> Bool
== :: Bit -> Bit -> Bool
$c== :: Bit -> Bit -> Bool
Eq)

-- | Result of various utilty functions. Indicates the origin of a certain bit:
-- either a literal from the constructor (or an undefined bit), or from a
-- literal.
data BitOrigin
  -- | Literal (high, low, undefind)
  = Lit [Bit]
  -- | Bits originate from a field. Field /fieldnr/ /from/ /downto/.
  | Field
      Int
      -- Field number
      Int
      -- Start bit (from..)
      Int
      -- End bit (inclusive, ..downto)
        deriving (Int -> BitOrigin -> ShowS
[BitOrigin] -> ShowS
BitOrigin -> String
(Int -> BitOrigin -> ShowS)
-> (BitOrigin -> String)
-> ([BitOrigin] -> ShowS)
-> Show BitOrigin
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BitOrigin] -> ShowS
$cshowList :: [BitOrigin] -> ShowS
show :: BitOrigin -> String
$cshow :: BitOrigin -> String
showsPrec :: Int -> BitOrigin -> ShowS
$cshowsPrec :: Int -> BitOrigin -> ShowS
Show)

-- | Same as bitOrigins, but each item in result list represents a single bit.
bitOrigins'
  :: DataRepr'
  -> ConstrRepr'
  -> [BitOrigin]
bitOrigins' :: DataRepr' -> ConstrRepr' -> [BitOrigin]
bitOrigins' (DataRepr' Type'
_ Int
size [ConstrRepr']
constrs) (ConstrRepr' Text
_ Int
_ BitMask
mask BitMask
value [BitMask]
fields) =
  (Int -> BitOrigin) -> [Int] -> [BitOrigin]
forall a b. (a -> b) -> [a] -> [b]
map Int -> BitOrigin
bitOrigin ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int
0..Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1])
    where
      commonMask :: BitMask
commonMask = (BitMask -> BitMask -> BitMask) -> BitMask -> [BitMask] -> BitMask
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl BitMask -> BitMask -> BitMask
forall a. Bits a => a -> a -> a
(.|.) BitMask
0 [BitMask
m | ConstrRepr' Text
_ Int
_ BitMask
m BitMask
_ [BitMask]
_ <- [ConstrRepr']
constrs]

      -- | Determine origin of single bit
      bitOrigin :: Int -> BitOrigin
      bitOrigin :: Int -> BitOrigin
bitOrigin Int
n =
        if BitMask -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BitMask
mask Int
n then
          [Bit] -> BitOrigin
Lit [if BitMask -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BitMask
value Int
n then Bit
H else Bit
L]
        else
          case (BitMask -> Bool) -> [BitMask] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\BitMask
fmask -> BitMask -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BitMask
fmask Int
n) [BitMask]
fields of
            Maybe Int
Nothing ->
              if BitMask -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BitMask
commonMask Int
n then
                -- This bit is not used in this constructor, nor is it part of
                -- a field. We cannot leave this value uninitialized though, as
                -- this would result in undefined behavior when matching other
                -- constructors. We therefore take a /default/ bit value.
                [Bit] -> BitOrigin
Lit [if BitMask -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit BitMask
value Int
n then Bit
H else Bit
L]
              else
                -- This bit is not used in this constructor, nor is it part of
                -- a field, nor is it used in other constructors. It is safe to
                -- leave this bit uninitialized.
                [Bit] -> BitOrigin
Lit [Bit
U]
            Just Int
fieldn ->
              let fieldbitn :: Int
fieldbitn = [Bool] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ([Bool] -> Int) -> [Bool] -> Int
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool) -> [Bool] -> [Bool]
forall a. (a -> Bool) -> [a] -> [a]
filter Bool -> Bool
forall a. a -> a
id
                                     ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
take Int
n
                                     ([Bool] -> [Bool]) -> [Bool] -> [Bool]
forall a b. (a -> b) -> a -> b
$ BitMask -> [Bool]
forall a. (Num a, Bits a, Ord a) => a -> [Bool]
bitsToBools ([BitMask]
fields [BitMask] -> Int -> BitMask
forall a. [a] -> Int -> a
!! Int
fieldn) in
              Int -> Int -> Int -> BitOrigin
Field Int
fieldn Int
fieldbitn Int
fieldbitn

-- | Given a type size and one of its constructor this function will yield a
-- specification of which bits the whole type is made up of. I.e., a
-- construction plan on how to make the whole data structure, given its
-- individual constructor fields.
bitOrigins
  :: DataRepr'
  -> ConstrRepr'
  -> [BitOrigin]
bitOrigins :: DataRepr' -> ConstrRepr' -> [BitOrigin]
bitOrigins DataRepr'
dataRepr ConstrRepr'
constrRepr =
  [BitOrigin] -> [BitOrigin]
mergeOrigins (DataRepr' -> ConstrRepr' -> [BitOrigin]
bitOrigins' DataRepr'
dataRepr ConstrRepr'
constrRepr)

-- | Merge consequtive Constructor and Field fields (if applicable).
mergeOrigins :: [BitOrigin] -> [BitOrigin]
mergeOrigins :: [BitOrigin] -> [BitOrigin]
mergeOrigins (Lit [Bit]
n : Lit [Bit]
n' : [BitOrigin]
fs) =
  -- Literals can always be merged:
  [BitOrigin] -> [BitOrigin]
mergeOrigins ([BitOrigin] -> [BitOrigin]) -> [BitOrigin] -> [BitOrigin]
forall a b. (a -> b) -> a -> b
$ [Bit] -> BitOrigin
Lit ([Bit]
n [Bit] -> [Bit] -> [Bit]
forall a. [a] -> [a] -> [a]
++ [Bit]
n') BitOrigin -> [BitOrigin] -> [BitOrigin]
forall a. a -> [a] -> [a]
: [BitOrigin]
fs
mergeOrigins (Field Int
n Int
s Int
e : Field Int
n' Int
s' Int
e' : [BitOrigin]
fs)
  -- Consequtive fields with same field number merged:
  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n'   = [BitOrigin] -> [BitOrigin]
mergeOrigins ([BitOrigin] -> [BitOrigin]) -> [BitOrigin] -> [BitOrigin]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> BitOrigin
Field Int
n Int
s Int
e' BitOrigin -> [BitOrigin] -> [BitOrigin]
forall a. a -> [a] -> [a]
: [BitOrigin]
fs
  -- No merge:
  | Bool
otherwise = Int -> Int -> Int -> BitOrigin
Field Int
n Int
s Int
e BitOrigin -> [BitOrigin] -> [BitOrigin]
forall a. a -> [a] -> [a]
: [BitOrigin] -> [BitOrigin]
mergeOrigins (Int -> Int -> Int -> BitOrigin
Field Int
n' Int
s' Int
e' BitOrigin -> [BitOrigin] -> [BitOrigin]
forall a. a -> [a] -> [a]
: [BitOrigin]
fs)
-- Base cases:
mergeOrigins (BitOrigin
x:[BitOrigin]
fs) = BitOrigin
x BitOrigin -> [BitOrigin] -> [BitOrigin]
forall a. a -> [a] -> [a]
: [BitOrigin] -> [BitOrigin]
mergeOrigins [BitOrigin]
fs
mergeOrigins []     = []

-- | Convert a number to a list of its bits
-- Output is ordered from least to most significant bit.
-- Only outputs bits until the highest set bit.
--
-- @
-- > map bitsToBools [0..2]
-- [[],[True],[False,True]])
-- @
--
-- This also works for variable sized number like Integer.
-- But not for negative numbers, because negative Integers have infinite bits set.
bitsToBools :: (Num a, Bits a, Ord a) => a -> [Bool]
bitsToBools :: a -> [Bool]
bitsToBools a
0 = []
bitsToBools a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = String -> [Bool]
forall a. HasCallStack => String -> a
error String
"Can't deal with negative bitmasks/values"
              | Bool
otherwise = a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
n Int
0 Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: a -> [Bool]
forall a. (Num a, Bits a, Ord a) => a -> [Bool]
bitsToBools (a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)


offsets
  :: Int
  -- ^ Offset
  -> [Bool]
  -- ^ Group
  -> (Int, (Int, [Bool]))
offsets :: Int -> [Bool] -> (Int, (Int, [Bool]))
offsets Int
offset [Bool]
group' =
  ([Bool] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Bool]
group' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset, (Int
offset, [Bool]
group'))

-- | Determine consecutively set bits in word. Will produce ranges from high
-- to low. Examples:
--
--   bitRanges 0b10          == [(1,1)]
--   bitRanges 0b101         == [(2,2),(0,0)]
--   bitRanges 0b10011001111 == [(10,10),(7,6),(3,0)]
--
bitRanges :: Integer -> [(Int, Int)]
bitRanges :: BitMask -> [(Int, Int)]
bitRanges BitMask
word = [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
reverse ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap [(Int, Int)]
ranges
  where
    ranges :: [(Int, Int)]
ranges  = ((Int, [Bool]) -> (Int, Int)) -> [(Int, [Bool])] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
ofs, [Bool]
grp) -> (Int
ofs, Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+[Bool] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Bool]
grpInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [(Int, [Bool])]
groups'
    groups' :: [(Int, [Bool])]
groups' = ((Int, [Bool]) -> Bool) -> [(Int, [Bool])] -> [(Int, [Bool])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Bool] -> Bool
forall a. [a] -> a
head ([Bool] -> Bool)
-> ((Int, [Bool]) -> [Bool]) -> (Int, [Bool]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, [Bool]) -> [Bool]
forall a b. (a, b) -> b
snd) [(Int, [Bool])]
groups
    groups :: [(Int, [Bool])]
groups  = (Int, [(Int, [Bool])]) -> [(Int, [Bool])]
forall a b. (a, b) -> b
snd ((Int, [(Int, [Bool])]) -> [(Int, [Bool])])
-> (Int, [(Int, [Bool])]) -> [(Int, [Bool])]
forall a b. (a -> b) -> a -> b
$ (Int -> [Bool] -> (Int, (Int, [Bool])))
-> Int -> [[Bool]] -> (Int, [(Int, [Bool])])
forall (t :: Type -> Type) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Int -> [Bool] -> (Int, (Int, [Bool]))
offsets Int
0 ([Bool] -> [[Bool]]
forall a. Eq a => [a] -> [[a]]
group [Bool]
bits)
    bits :: [Bool]
bits    = BitMask -> [Bool]
forall a. (Num a, Bits a, Ord a) => a -> [Bool]
bitsToBools BitMask
word

isContinuousMask :: Integer -> Bool
isContinuousMask :: BitMask -> Bool
isContinuousMask BitMask
word =
  -- Use case expression so we avoid calculating all groups
  case BitMask -> [(Int, Int)]
bitRanges BitMask
word of
    -- At least two groups:
    ((Int, Int)
_:(Int, Int)
_:[(Int, Int)]
_) -> Bool
False
    -- Zero or one group:
    [(Int, Int)]
_       -> Bool
True