diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,27 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) +## 0.6 *November 17th 2014* + +* New features: + * Add `Fractional` instance for `Fixed` [#9](https://github.com/christiaanb/clash-prelude/issues/9) + * Make indexing/subscript of `Vec` ascending [#4](https://github.com/christiaanb/clash-prelude/issues/4) + * Add separate `BitVector` type, which has a descending index. + * Add bit indexing operators, including the index/subscript operator `(!)`. + * Add bit reduction operators: `reduceOr`, `reduceAnd`, `reduceOr`. + * Rename `BitVector` class to `BitPack` with `pack` and `unpack` class methods. + * Rename `Pack` class to `Bundle` with `bundle` and `unbundle` class methods. + * Strip all `Vec` functions from their `v` prefix, i.e. `vmap` -> `map`. + * Rename `Vec` indexing operator from `(!)` to `(!!)`. + * Combine `Add` and `Mult` class into `ExtendingNum` class. + * Add extend and truncate methods to the `Resize` class. + * Add `SaturatingNum` class with saturating numeric operators. + * Add multitude of lifted `Signal` operators, i.e. `(.==.) :: Eq a => Signal a -> Signal a -> Signal Bool` + * Add `CLaSH.Signal.Delayed` with functions and data types for delay-annotated signals to support safe synchronisation. + * Add `CLASH.Prelude.DataFlow` with functions and data types to create self-synchronising circuits based on data-flow principles. + +* Fixes bugs: + * Remove deprecated 'Arrow' instance for and related functions for `Comp` [#5](https://github.com/christiaanb/clash-prelude/issues/5) + ## 0.5.1 *June 5th 2014* * New features: diff --git a/clash-prelude.cabal b/clash-prelude.cabal --- a/clash-prelude.cabal +++ b/clash-prelude.cabal @@ -1,5 +1,5 @@ Name: clash-prelude -Version: 0.5.1 +Version: 0.6 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -35,6 +35,8 @@ Extra-source-files: README.md CHANGELOG.md +extra-doc-files: doc/*.svg + Cabal-version: >=1.10 source-repository head @@ -45,28 +47,66 @@ HS-Source-Dirs: src default-language: Haskell2010 - ghc-options: -Wall -fwarn-tabs + ghc-options: -Wall -fwarn-tabs -fexpose-all-unfoldings - Exposed-modules: CLaSH.Bit - CLaSH.Class.BitVector + Exposed-modules: CLaSH.Class.BitPack CLaSH.Class.Num + CLaSH.Class.Resize + CLaSH.Prelude + CLaSH.Prelude.BitIndex + CLaSH.Prelude.BitReduction + CLaSH.Prelude.BlockRam + CLaSH.Prelude.DataFlow CLaSH.Prelude.Explicit + CLaSH.Prelude.Mealy + CLaSH.Prelude.Testbench + CLaSH.Promoted.Nat CLaSH.Promoted.Nat.TH CLaSH.Promoted.Nat.Literals CLaSH.Promoted.Ord + CLaSH.Promoted.Symbol + + CLaSH.Signal + CLaSH.Signal.Bundle + CLaSH.Signal.Delayed CLaSH.Signal.Explicit - CLaSH.Signal.Implicit + CLaSH.Signal.Internal + CLaSH.Sized.Fixed + CLaSH.Sized.Index CLaSH.Sized.Signed CLaSH.Sized.Unsigned CLaSH.Sized.Vector + + CLaSH.Sized.Internal.BitVector + CLaSH.Sized.Internal.Index + CLaSH.Sized.Internal.Signed + CLaSH.Sized.Internal.Unsigned + CLaSH.Tutorial - Other-modules: CLaSH.Signal.Types + other-extensions: DataKinds + DefaultSignatures + DeriveDataTypeable + FlexibleContexts + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MagicHash + MultiParamTypeClasses + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeFamilies + TypeOperators + UndecidableInstances Build-depends: base >= 4.7.0.0 && < 5, data-default >= 0.5.3, + integer-gmp >= 0.5.1.0, + ghc-prim >= 0.3.1.0, template-haskell >= 2.9.0.0, th-lift >= 0.5.6 diff --git a/doc/firstDF.svg b/doc/firstDF.svg new file mode 100644 --- /dev/null +++ b/doc/firstDF.svg @@ -0,0 +1,3 @@ + + +2014-11-04 10:45ZCanvas 1Layer 1aaEndatavalidreadydatavalidreadyfaEncEnccEnfirstDF fbbEnbEncEnccEn diff --git a/doc/idDF.svg b/doc/idDF.svg new file mode 100644 --- /dev/null +++ b/doc/idDF.svg @@ -0,0 +1,3 @@ + + +2014-11-05 09:25ZCanvas 1Layer 1aEnaaEnidDFaEnaaEn diff --git a/doc/lockStep.svg b/doc/lockStep.svg new file mode 100644 --- /dev/null +++ b/doc/lockStep.svg @@ -0,0 +1,3 @@ + + +2014-11-05 10:53ZCanvas 1Layer 1datavalidreadydatavalidreadyff `parDF` gdatavalidreadydatavalidreadyg&&&&&&lockStep(f `parDF` g) `seqDF` lockStepdatavalidreadydatavalidreadyh(f `parDF` g) `seqDF` lockStep `seqDF` h diff --git a/doc/loopDF.svg b/doc/loopDF.svg new file mode 100644 --- /dev/null +++ b/doc/loopDF.svg @@ -0,0 +1,3 @@ + + +2014-11-05 14:15ZCanvas 1Layer 1datavalidreadydatavalidreadyhstepLockloopDF hlockStepvalidreadyvalidready diff --git a/doc/parDF.svg b/doc/parDF.svg new file mode 100644 --- /dev/null +++ b/doc/parDF.svg @@ -0,0 +1,3 @@ + + +2014-11-04 10:51ZCanvas 1Layer 1aaEndatavalidreadydatavalidreadyfaEnf `parDF` gbbEnbEnccEndatavalidreadydatavalidreadygcEnddEndEn diff --git a/doc/secondDF.svg b/doc/secondDF.svg new file mode 100644 --- /dev/null +++ b/doc/secondDF.svg @@ -0,0 +1,3 @@ + + +2014-11-04 10:49ZCanvas 1Layer 1aaEndatavalidreadydatavalidreadyfaEncEnccEnsecondDF fbbEnbEncEnccEn diff --git a/doc/seqDF.svg b/doc/seqDF.svg new file mode 100644 --- /dev/null +++ b/doc/seqDF.svg @@ -0,0 +1,3 @@ + + +2014-11-05 09:21ZCanvas 1Layer 1aaEndatavalidreadydatavalidreadyfaEnf `seqDF` gbbEnbEncEnccEndatavalidreadydatavalidreadyg diff --git a/doc/stepLock.svg b/doc/stepLock.svg new file mode 100644 --- /dev/null +++ b/doc/stepLock.svg @@ -0,0 +1,3 @@ + + +2014-11-05 13:00ZCanvas 1Layer 1&&datavalidreadydatavalidreadyhh `seqDF` stepLock `seqDF` (f `parDF` g)datavalidreadydatavalidreadyff `parDF` gdatavalidreadydatavalidreadyg&&&&stepLockh `seqDF` stepLock diff --git a/doc/swapDF.svg b/doc/swapDF.svg new file mode 100644 --- /dev/null +++ b/doc/swapDF.svg @@ -0,0 +1,3 @@ + + +2014-11-04 11:00ZCanvas 1Layer 1aEnaaEnswapDFbEnbbEnbEnbbEnaEnaaEn diff --git a/src/CLaSH/Bit.hs b/src/CLaSH/Bit.hs deleted file mode 100644 --- a/src/CLaSH/Bit.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - -module CLaSH.Bit - (Bit(..)) -where - -import Data.Bits -import Data.Default -import Language.Haskell.TH.Lift - --- | Two-level logic -data Bit = L -- ^ Low - | H -- ^ High - -instance Eq Bit where - (==) = eqBit - -{-# NOINLINE eqBit #-} -eqBit :: Bit -> Bit -> Bool -eqBit L L = True -eqBit H H = True -eqBit _ _ = False - -instance Show Bit where - show H = "1" - show L = "0" - -instance Default Bit where - def = L - -deriveLift ''Bit - -{-# NOINLINE bAnd #-} -bAnd :: Bit -> Bit -> Bit -bAnd H H = H -bAnd _ _ = L - -{-# NOINLINE bOr #-} -bOr :: Bit -> Bit -> Bit -bOr L L = L -bOr _ _ = H - -{-# NOINLINE bXor #-} -bXor :: Bit -> Bit -> Bit -bXor L L = L -bXor H H = L -bXor _ _ = H - -{-# NOINLINE bNot #-} -bNot :: Bit -> Bit -bNot L = H -bNot H = L - -instance Bits Bit where - (.&.) = bAnd - (.|.) = bOr - xor = bXor - complement = bNot - bit = const H - testBit H _ = True - testBit _ _ = False - bitSizeMaybe = const (Just 1) - isSigned = const False - popCount H = 1 - popCount _ = 0 diff --git a/src/CLaSH/Class/BitPack.hs b/src/CLaSH/Class/BitPack.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Class/BitPack.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module CLaSH.Class.BitPack + ( BitPack (..) + , bitCoerce + ) +where + +import GHC.TypeLits (KnownNat, Nat, type (+), type (*)) +import Prelude hiding (map) + +import CLaSH.Sized.BitVector (BitVector, (++#), high, low) +import CLaSH.Sized.Internal.BitVector (split#) +import CLaSH.Sized.Vector (Vec, concatBitVector#, map, + unconcatBitVector#) + +-- | Convert to and from a 'BitVector' +class BitPack a where + -- | Number of 'CLaSH.Sized.BitVector.Bit's needed to represents elements + -- of type @a@ + type BitSize a :: Nat + -- | Convert element of type @a@ to a 'BitVector' + -- + -- >>> pack (-5 :: Signed 6) + -- 111011 + pack :: a -> BitVector (BitSize a) + -- | Convert a 'BitVector' to an element of type @a@ + -- + -- >>> pack (-5 :: Signed 6) + -- 111011 + -- >>> let x = pack (-5 :: Signed 6) + -- >>> unpack x :: Unsigned 6 + -- 59 + -- >>> pack (59 :: Unsigned 6) + -- 111011 + unpack :: BitVector (BitSize a) -> a + +{-# INLINE bitCoerce #-} +-- | Coerce a value from one type to another through its bit representation. +-- +-- >>> pack (-5 :: Signed 6) +-- 111011 +-- >>> bitCoerce (-5 :: Signed 6) :: Unsigned 6 +-- 59 +-- >>> pack (59 :: Unsigned 6) +-- 111011 +bitCoerce :: (BitPack a, BitPack b, BitSize a ~ BitSize b) + => a + -> b +bitCoerce = unpack . pack + +instance BitPack Bool where + type BitSize Bool = 1 + pack True = high + pack False = low + + unpack bv = if bv == high then True else False + +instance BitPack (BitVector n) where + type BitSize (BitVector n) = n + pack v = v + unpack v = v + +instance (KnownNat (BitSize a), KnownNat (BitSize b), BitPack a, BitPack b) => + BitPack (a,b) where + type BitSize (a,b) = BitSize a + BitSize b + pack (a,b) = pack a ++# pack b + unpack ab = let (a,b) = split# ab in (unpack a, unpack b) + +instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where + type BitSize (Vec n a) = n * (BitSize a) + pack = concatBitVector# . map pack + unpack = map unpack . unconcatBitVector# diff --git a/src/CLaSH/Class/BitVector.hs b/src/CLaSH/Class/BitVector.hs deleted file mode 100644 --- a/src/CLaSH/Class/BitVector.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module CLaSH.Class.BitVector where - -import CLaSH.Bit -import CLaSH.Sized.Vector -import GHC.TypeLits - --- | Convert types from and to a 'Vec'tor of 'Bit's -class BitVector a where - -- | Number of 'Bit's needed to represents elements of type @a@ - type BitSize a :: Nat - -- | Convert element of type @a@ to a 'Vec' of 'Bit's - toBV :: KnownNat (BitSize a) => a -> Vec (BitSize a) Bit - -- | Convert a 'Vec' of 'Bit's to an element of type @a@ - fromBV :: KnownNat (BitSize a) => Vec (BitSize a) Bit -> a - -instance BitVector Bit where - type BitSize Bit = 1 - toBV = (:> Nil) - fromBV = vhead - -instance BitVector Bool where - type BitSize Bool = 1 - toBV = (:> Nil) . toBit - where - toBit True = H - toBit False = L - fromBV = fromBit . vhead - where - fromBit H = True - fromBit L = False - -instance (KnownNat (BitSize a), KnownNat (BitSize b), BitVector a, BitVector b) => BitVector (a,b) where - type BitSize (a,b) = (BitSize a) + (BitSize b) - toBV (a,b) = toBV a <++> toBV b - fromBV bv = (fromBV (vtakeI bv), fromBV (vdropI bv)) - -instance (KnownNat n, KnownNat (BitSize a), BitVector a) => BitVector (Vec n a) where - type BitSize (Vec n a) = n * (BitSize a) - toBV = vconcat . vmap toBV - fromBV = vmap fromBV . vunconcatI diff --git a/src/CLaSH/Class/Num.hs b/src/CLaSH/Class/Num.hs --- a/src/CLaSH/Class/Num.hs +++ b/src/CLaSH/Class/Num.hs @@ -1,22 +1,72 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module CLaSH.Class.Num where +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module CLaSH.Class.Num + ( -- * Arithmetic functions for arguments and results of different precision + ExtendingNum (..) + -- * Saturating arithmetic functions + , SaturationMode (..) + , SaturatingNum (..) + , boundedPlus + , boundedMin + , boundedMult + ) +where -import GHC.TypeLits +-- * Arithmetic functions for arguments and results of different precision --- | Implicitly adding or subtracting values of two different (sub-)types. -class Add a b where +-- | Adding, subtracting, and multiplying values of two different (sub-)types. +class ExtendingNum a b where + -- | Type of the result of the addition or subtraction type AResult a b + -- | Add values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. plus :: a -> b -> AResult a b + -- | Subtract values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. minus :: a -> b -> AResult a b - --- | Implicitly multiplying values of two different (sub-)types. -class Mult a b where + -- | Type of the result of the multiplication type MResult a b - mult :: a -> b -> MResult a b + -- | Multiply values of different (sub-)types, return a value of a (sub-)type + -- that is potentially different from either argument. + times :: a -> b -> MResult a b --- | Coerce a value to be represented by a different number of bits -class Resize f where - resize :: (KnownNat a, KnownNat b) => f a -> f b +-- * Saturating arithmetic functions + +-- | Determine how overflow and underflow are handled by the functions in +-- 'SaturatingNum' +data SaturationMode + = SatWrap -- ^ Wrap around on overflow and underflow + | SatBound -- ^ Become 'maxBound' on overflow, and 'minBound' on underflow + | SatZero -- ^ Become @0@ on overflow and underflow + | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' - 1@) on + -- underflow for signed numbers, and 'minBound' for unsigned + -- numbers. + deriving Eq + +-- | 'Num' operators in which overflow and underflow behaviour can be specified +-- using 'SaturationMode'. +class (Bounded a, Num a) => SaturatingNum a where + -- | Addition with parametrisable over- and underflow behaviour + satPlus :: SaturationMode -> a -> a -> a + -- | Subtraction with parametrisable over- and underflow behaviour + satMin :: SaturationMode -> a -> a -> a + -- | Multiplication with parametrisable over- and underflow behaviour + satMult :: SaturationMode -> a -> a -> a + +{-# INLINE boundedPlus #-} +-- | Addition that clips to 'maxBound' on overflow, and 'minBound' on underflow +boundedPlus :: SaturatingNum a => a -> a -> a +boundedPlus = satPlus SatBound + +{-# INLINE boundedMin #-} +-- | Subtraction that clips to 'maxBound' on overflow, and 'minBound' on +-- underflow +boundedMin :: SaturatingNum a => a -> a -> a +boundedMin = satMin SatBound + +{-# INLINE boundedMult #-} +-- | Multiplication that clips to 'maxBound' on overflow, and 'minBound' on +-- underflow +boundedMult :: SaturatingNum a => a -> a -> a +boundedMult = satMult SatBound diff --git a/src/CLaSH/Class/Resize.hs b/src/CLaSH/Class/Resize.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Class/Resize.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module CLaSH.Class.Resize where + +import GHC.TypeLits (KnownNat, Nat, type (+)) + +-- | Coerce a value to be represented by a different number of bits +class Resize (f :: Nat -> *) where + -- | A sign-preserving resize operation + -- + -- * For signed datatypes: Increasing the size of the number replicates the + -- sign bit to the left. Truncating a number to length L keeps the sign bit + -- and the rightmost L-1 bits. + -- + -- * For unsigned datatypes: Increasing the size of the number extends with + -- zeros to the left. Truncating a number of length N to a length L just + -- removes the left (most significant) N-L bits. + resize :: (KnownNat a, KnownNat b) => f a -> f b + -- | Perform a 'zeroExtend' for unsigned datatypes, and 'signExtend' for a + -- signed datatypes + extend :: (KnownNat a, KnownNat (b + a)) => f a -> f (b + a) + extend = resize + -- | Add extra zero bits in front of the MSB + zeroExtend :: (KnownNat a, KnownNat b, KnownNat (b + a)) => f a -> f (b + a) + -- | Add extra sign bits in front of the MSB + signExtend :: (KnownNat a, KnownNat (b + a)) => f a -> f (b + a) + -- | Remove bits from the MSB + truncateB :: KnownNat a => f (b + a) -> f a diff --git a/src/CLaSH/Prelude.hs b/src/CLaSH/Prelude.hs --- a/src/CLaSH/Prelude.hs +++ b/src/CLaSH/Prelude.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -O0 -fno-omit-interface-pragmas #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} {- | CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -25,37 +21,41 @@ explicitly clocked circuits in a multi-clock setting For now, "CLaSH.Prelude" is also the best starting point for exploring the - library. A tutorial module will be added within due time. + library. A preliminary version of a tutorial can be found in "CLaSH.Tutorial". -} module CLaSH.Prelude ( -- * Creating synchronous sequential circuits - (<^>) - , registerP - -- * 'Arrow' interface for synchronous sequential circuits - , Comp (..) - , (^^^) - , registerC - , simulateC + mealy + , mealyB + , (<^>) + , registerB -- * BlockRAM primitives , blockRam , blockRamPow2 - , blockRamC - , blockRamPow2C -- * Utility functions , window , windowD + , isRising + , isFalling -- * Testbench functions , sassert , stimuliGenerator , outputVerifier -- * Exported modules - -- ** Implicitly clocked synchronous signals - , module CLaSH.Signal.Implicit + -- ** Synchronous signals + , module CLaSH.Signal + , module CLaSH.Signal.Delayed + -- ** DataFlow interface + , module CLaSH.Prelude.DataFlow -- ** Datatypes - , module CLaSH.Bit + -- *** Bit vectors + , module CLaSH.Sized.BitVector + , module CLaSH.Prelude.BitIndex + , module CLaSH.Prelude.BitReduction -- *** Arbitrary-width numbers , module CLaSH.Sized.Signed , module CLaSH.Sized.Unsigned + , module CLaSH.Sized.Index -- *** Fixed point numbers , module CLaSH.Sized.Fixed -- *** Fixed size vectors @@ -71,348 +71,103 @@ , Lift (..), deriveLift -- ** Type classes -- *** CLaSH - , module CLaSH.Class.BitVector + , module CLaSH.Class.BitPack , module CLaSH.Class.Num + , module CLaSH.Class.Resize -- *** Other - , module Control.Arrow , module Control.Applicative , module Data.Bits , module Data.Default + , module Prelude ) where -import Control.Arrow import Control.Applicative -import Control.Category as Category import Data.Bits import Data.Default -import Debug.Trace (trace) -import CLaSH.Class.BitVector +import GHC.TypeLits +import Language.Haskell.TH.Lift (Lift(..),deriveLift) +import Prelude hiding ((++), (!!), concat, drop, foldl, + foldl1, foldr, foldr1, head, init, + iterate, last, length, map, repeat, + replicate, reverse, scanl, scanr, + splitAt, tail, take, unzip, zip, + zipWith) + +import CLaSH.Class.BitPack import CLaSH.Class.Num +import CLaSH.Class.Resize +import CLaSH.Prelude.BitIndex +import CLaSH.Prelude.BitReduction +import CLaSH.Prelude.BlockRam (blockRam, blockRamPow2) +import CLaSH.Prelude.Explicit (cregisterB, cwindow, cwindowD, cisRising, + cisFalling) +import CLaSH.Prelude.Mealy (mealy, mealyB, (<^>)) +import CLaSH.Prelude.DataFlow +import CLaSH.Prelude.Testbench (sassert, stimuliGenerator, outputVerifier) import CLaSH.Promoted.Nat import CLaSH.Promoted.Nat.TH import CLaSH.Promoted.Nat.Literals import CLaSH.Promoted.Ord +import CLaSH.Sized.BitVector import CLaSH.Sized.Fixed +import CLaSH.Sized.Index import CLaSH.Sized.Signed import CLaSH.Sized.Unsigned import CLaSH.Sized.Vector -import CLaSH.Bit -import CLaSH.Signal.Implicit -import GHC.TypeLits -import Language.Haskell.TH.Lift (Lift(..),deriveLift) +import CLaSH.Signal +import CLaSH.Signal.Delayed +import CLaSH.Signal.Explicit (systemClock) -{-# INLINABLE window #-} +{-# INLINE window #-} -- | Give a window over a 'Signal' -- -- > window4 :: Signal Int -> Vec 4 (Signal Int) -- > window4 = window -- --- >>> simulateP window4 [1,2,3,4,5,... +-- >>> simulateB window4 [1,2,3,4,5,... -- [<1,0,0,0>, <2,1,0,0>, <3,2,1,0>, <4,3,2,1>, <5,4,3,2>,... -window :: (KnownNat (n + 1), Default a) - => Signal a -- ^ Signal to create a window over - -> Vec ((n + 1) + 1) (Signal a) -- ^ Window of at least size 2 -window x = x :> prev - where - prev = registerP (vcopyI def) next - next = x +>> prev +window :: (KnownNat n, Default a) + => Signal a -- ^ Signal to create a window over + -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 +window = cwindow systemClock -{-# INLINABLE windowD #-} +{-# INLINE windowD #-} -- | Give a delayed window over a 'Signal' -- -- > windowD3 :: Signal Int -> Vec 3 (Signal Int) -- > windowD3 = windowD -- --- >>> simulateP windowD3 [1,2,3,4,... +-- >>> simulateB windowD3 [1,2,3,4,... -- [<0,0,0>, <1,0,0>, <2,1,0>, <3,2,1>, <4,3,2>,... windowD :: (KnownNat (n + 1), Default a) => Signal a -- ^ Signal to create a window over -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 -windowD x = prev - where - prev = registerP (vcopyI def) next - next = x +>> prev - -{-# INLINABLE (<^>) #-} --- | Create a synchronous function from a combinational function describing --- a mealy machine --- --- > mac :: Int -- Current state --- > -> (Int,Int) -- Input --- > -> (Int,Int) -- (Updated state, output) --- > mac s (x,y) = (s',s) --- > where --- > s' = x * y + s --- > --- > topEntity :: (Signal Int, Signal Int) -> Signal Int --- > topEntity = mac <^> 0 --- --- >>> simulateP topEntity [(1,1),(2,2),(3,3),(4,4),... --- [0,1,5,14,30,... --- --- Synchronous sequential functions can be composed just like their combinational counterpart: --- --- > dualMac :: (Signal Int, Signal Int) --- > -> (Signal Int, Signal Int) --- > -> Signal Int --- > dualMac (a,b) (x,y) = s1 + s2 --- > where --- > s1 = (mac <^> 0) (a,b) --- > s2 = (mac <^> 0) (x,y) -(<^>) :: (Pack i, Pack o) - => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (SignalP i -> SignalP o) -- ^ Synchronous sequential function with input and output matching that of the mealy machine -f <^> iS = \i -> let (s',o) = unpack $ f <$> s <*> pack i - s = register iS s' - in unpack o +windowD = cwindowD systemClock -{-# INLINABLE registerP #-} +{-# INLINE registerB #-} -- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)') -- -- > rP :: (Signal Int,Signal Int) -> (Signal Int, Signal Int) --- > rP = registerP (8,8) --- --- >>> simulateP rP [(1,1),(2,2),(3,3),... --- [(8,8),(1,1),(2,2),(3,3),... -registerP :: Pack a => a -> SignalP a -> SignalP a -registerP i = unpack Prelude.. register i Prelude.. pack - -{-# NOINLINE blockRam #-} --- | Create a blockRAM with space for @n@ elements. --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > bram40 :: Signal (Unsigned 6) -> Signal (Unsigned 6) -> Signal Bool -> Signal Bit -> Signal Bit --- > bram40 = blockRam (vcopy d40 H) -blockRam :: (Pack a, KnownNat n, KnownNat m) - => Vec n a -- ^ Initial content of the BRAM, also determines the size ,@n@, of the BRAM. - -- NB: *MUST* be a constant. - -> Signal (Unsigned m) -- ^ Write address @w@ - -> Signal (Unsigned m) -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address @w@) - -> Signal a -- ^ Value of the 'blockRAM' at address @r@ from the previous clock cycle -blockRam binit wr rd en din = pack $ (bram' <^> (binit,undefined)) (wr,rd,en,din) - where - bram' (ram,o) (w,r,e,d) = ((ram',o'),o) - where - ram' | e = vreplace ram w d - | otherwise = ram - o' = ram ! r - -{-# DEPRECATED blockRamC "'Comp' is deprecated and will be removed in version 0.6, use 'blockRam' instead" #-} --- | Create a blockRAM with space for @n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > bramC40 :: Comp (Unsigned 6, Unsigned 6, Bool, Bit) Bit --- > bramC40 = blockRamC (vcopy d40 H) -blockRamC :: (KnownNat n, KnownNat m, Pack a) - => Vec n a -- ^ Initial content of the BRAM, also determines the size ,@n@, of the BRAM. - -- NB: *MUST* be a constant. - -> Comp (Unsigned m, Unsigned m, Bool, a) a -blockRamC n = C ((\(wr,rd,en,din) -> blockRam n wr rd en din) Prelude.. unpack) - -{-# INLINABLE blockRamPow2 #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > bram32 :: Signal (Unsigned 5) -> Signal (Unsigned 5) -> Signal Bool -> Signal Bit -> Signal Bit --- > bram32 = blockRamPow2 (vcopy d32 H) -blockRamPow2 :: (KnownNat (2^n), KnownNat n, Pack a) - => Vec (2^n) a -- ^ Initial content of the BRAM, also determines the size ,@2^n@, of the BRAM. - -- NB: *MUST* be a constant. - -> Signal (Unsigned n) -- ^ Write address @w@ - -> Signal (Unsigned n) -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address @w@) - -> Signal a -- ^ Value of the 'blockRAM' at address @r@ from the previous clock cycle -blockRamPow2 = blockRam - -{-# DEPRECATED blockRamPow2C "'Comp' is deprecated and will be removed in version 0.6, use 'blockRamPow2' instead" #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > bramC32 :: Comp (Unsigned 5, Unsigned 5, Bool, Bit) Bit --- > bramC32 = blockRamPow2C (vcopy d32 H) -blockRamPow2C :: (KnownNat (2^n), KnownNat n, Pack a) - => Vec (2^n) a -- ^ Initial content of the BRAM, also determines the size ,@2^n@, of the BRAM. - -- NB: *MUST* be a constant. - -> Comp (Unsigned n, Unsigned n, Bool, a) a -blockRamPow2C n = C ((\(wr,rd,en,din) -> blockRamPow2 n wr rd en din) Prelude.. unpack) - -{-# DEPRECATED Comp "Will be removed in version 0.6. Use 'Applicative' interface and ('<^>') instead" #-} --- | 'Comp'onent: an 'Arrow' interface to synchronous sequential functions -newtype Comp a b = C { asFunction :: Signal a -> Signal b } - -instance Category Comp where - id = C Prelude.id - (C f) . (C g) = C (f Prelude.. g) - -instance Arrow Comp where - arr = C Prelude.. fmap - first (C f) = C $ pack Prelude.. (f >< Prelude.id) Prelude.. unpack - where - (g >< h) (x,y) = (g x,h y) - -instance ArrowLoop Comp where - loop (C f) = C $ simpleLoop (unpack Prelude.. f Prelude.. pack) - where - simpleLoop g b = let ~(c,d) = g (b,d) - in c - -{-# DEPRECATED registerC "'Comp' is deprecated and will be removed in version 0.6, use 'register' instead" #-} --- | Create a 'register' 'Comp'onent --- --- > rC :: Comp (Int,Int) (Int,Int) --- > rC = registerC (8,8) +-- > rP = registerB (8,8) -- --- >>> simulateC rP [(1,1),(2,2),(3,3),... +-- >>> simulateB rP [(1,1),(2,2),(3,3),... -- [(8,8),(1,1),(2,2),(3,3),... -registerC :: a -> Comp a a -registerC = C Prelude.. register - -{-# DEPRECATED simulateC "'Comp' is deprecated and will be removed in version 0.6, use 'simulate' instead" #-} --- | Simulate a 'Comp'onent given a list of samples --- --- >>> simulateC (registerC 8) [1, 2, 3, ... --- [8, 1, 2, 3, ... -simulateC :: Comp a b -> [a] -> [b] -simulateC f = simulate (asFunction f) - -{-# DEPRECATED (^^^) "Will be removed in version 0.6. Use 'Applicative' interface and ('<^>') instead" #-} -{-# INLINABLE (^^^) #-} --- | Create a synchronous 'Comp'onent from a combinational function describing --- a mealy machine --- --- > mac :: Int -- Current state --- > -> (Int,Int) -- Input --- > -> (Int,Int) -- (Updated state, output) --- > mac s (x,y) = (s',s) --- > where --- > s' = x * y + s --- > --- > topEntity :: Comp (Int,Int) Int --- > topEntity = mac ^^^ 0 --- --- >>> simulateC topEntity [(1,1),(2,2),(3,3),(4,4),... --- [0,1,5,14,30,... --- --- Synchronous sequential must be composed using the 'Arrow' syntax --- --- > dualMac :: Comp (Int,Int,Int,Int) Int --- > dualMac = proc (a,b,x,y) -> do --- > rec s1 <- mac ^^^ 0 -< (a,b) --- > s2 <- mac ^^^ 0 -< (x,y) --- > returnA -< (s1 + s2) -(^^^) :: (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> Comp i o -- ^ Synchronous sequential 'Comp'onent with input and output matching that of the mealy machine -f ^^^ sI = C $ \i -> let (s',o) = unpack $ f <$> s <*> i - s = register sI s' - in o - -{-# NOINLINE sassert #-} --- | Compares the first two arguments for equality and logs a warning when they --- are not equal. The second argument is considered the expected value. This --- function simply returns the third argument unaltered as its result. This --- function is used by 'outputVerifier'. --- --- This function is translated to the following VHDL: --- --- > sassert_block : block --- > begin --- > -- pragma translate_off --- > process(clk_1000,reset_1000,arg0,arg1) is --- > begin --- > if (rising_edge(clk_1000) or rising_edge(reset_1000)) then --- > assert (arg0 = arg1) report ("expected: " & to_string (arg1) & \", actual: \" & to_string (arg0)) severity error; --- > end if; --- > end process; --- > -- pragma translate_on --- > result <= arg2; --- > end block; --- --- And can, due to the pragmas, be used in synthesizable designs -sassert :: (Eq a, Show a) - => Signal a -- ^ Checked value - -> Signal a -- ^ Expected value - -> Signal b -- ^ Returned value - -> Signal b -sassert = liftA3 - (\a' b' c' -> if a' == b' then c' - else trace ("\nexpected value: " ++ show b' ++ ", not equal to actual value: " ++ show a') c') - -{-# INLINABLE stimuliGenerator #-} --- | To be used as a one of the functions to create the \"magical\" 'testInput' --- value, which the CλaSH compilers looks for to create the stimulus generator --- for the generated VHDL testbench. --- --- Example: --- --- > testInput :: Signal Int --- > testInput = stimuliGenerator $(v [(1::Int),3..21]) --- --- >>> sample testInput --- [1,3,5,7,9,11,13,15,17,19,21,21,21,... -stimuliGenerator :: forall l a . KnownNat l - => Vec l a -- ^ Samples to generate - -> Signal a -- ^ Signal of given samples -stimuliGenerator samples = - let (r,o) = unpack (genT <$> register (fromInteger (maxIndex samples)) r) - in o - where - genT :: Unsigned l -> (Unsigned l, a) - genT s = (s',samples ! s) - where - s' = if s > 0 then s - 1 - else s +registerB :: Bundle a => a -> Unbundled' a -> Unbundled' a +registerB = cregisterB systemClock -{-# INLINABLE outputVerifier #-} --- | To be used as a functions to generate the \"magical\" 'expectedOutput' --- function, which the CλaSH compilers looks for to create the signal verifier --- for the generated VHDL testbench. --- --- Example: --- --- > expectedOutput :: Signal Int -> Signal Bool --- > expectedOutput = outputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) --- --- >>> sample (expectedOutput (fromList ([0..10] ++ [10,10,10]))) --- [ --- expected value: 70, not equal to actual value: 0 --- False, --- expected value: 99, not equal to actual value: 1 --- False,False,False,False,False, --- expected value: 7, not equal to actual value: 6 --- False, --- expected value: 8, not equal to actual value: 7 --- False, --- expected value: 9, not equal to actual value: 8 --- False, --- expected value: 10, not equal to actual value: 9 --- False,True,True,... -outputVerifier :: forall l a . (KnownNat l, Eq a, Show a) - => Vec l a -- ^ Samples to compare with - -> Signal a -- ^ Signal to verify - -> Signal Bool -- ^ Indicator that all samples are verified -outputVerifier samples i = - let (s,o) = unpack (genT <$> register (fromInteger (maxIndex samples)) s) - (e,f) = unpack o - in sassert i e (register False f) - where - genT :: Unsigned l -> (Unsigned l, (a,Bool)) - genT s = (s',(samples ! s,finished)) - where - s' = if s >= 1 then s - 1 - else s +{-# INLINE isRising #-} +-- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound' +isRising :: (Bounded a, Eq a) + => a -- ^ Starting value + -> Signal a + -> Signal Bool +isRising = cisRising systemClock - finished = s == 0 +{-# INLINE isFalling #-} +-- | Give a pulse when the 'Signal' goes from 'maxBound' to 'minBound' +isFalling :: (Bounded a, Eq a) + => a -- ^ Starting value + -> Signal a + -> Signal Bool +isFalling = cisFalling systemClock diff --git a/src/CLaSH/Prelude/BitIndex.hs b/src/CLaSH/Prelude/BitIndex.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/BitIndex.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + +module CLaSH.Prelude.BitIndex where + +import GHC.TypeLits (KnownNat, type (+), type (-)) + +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Promoted.Nat (SNat) +import CLaSH.Sized.Internal.BitVector (BitVector, Bit, index#, lsb#, msb#, + replaceBit#, setSlice#, slice#, split#) + +{-# INLINE (!) #-} +-- | Get the bit at the specified bit index. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (7 :: Unsigned 6) +-- 000111 +-- >>> (7 :: Unsigned 6) ! 1 +-- 1 +-- >>> (7 :: Unsigned 6) ! 5 +-- 0 +-- >>> (7 :: Unsigned 6) ! 6 +-- *** Exception: (!): 6 is out of range [5..0] +(!) :: (BitPack a, KnownNat (BitSize a), Integral i) => a -> i -> Bit +(!) v i = index# (pack v) (fromIntegral i) + +{-# INLINE slice #-} +-- | Get a slice between bit index @m@ and and bit index @n@. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (7 :: Unsigned 6) +-- 000111 +-- >>> slice (7 :: Unsigned 6) d4 d2 +-- 001 +-- >>> slice (7 :: Unsigned 6) d6 d4 +-- +-- Couldn't match type ‘7 + i0’ with ‘6’ +-- The type variable ‘i0’ is ambiguous +-- Expected type: (6 + 1) + i0 +-- Actual type: BitSize (Unsigned 6) +-- In the expression: slice (7 :: Unsigned 6) d6 d4 +-- In an equation for ‘it’: it = slice (7 :: Unsigned 6) d6 d4 +slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => a -> SNat m -> SNat n + -> BitVector (m + 1 - n) +slice v m n = slice# (pack v) m n + +{-# INLINE split #-} +-- | Split a value of a bit size @m + n@ into a tuple of values with size @m@ +-- and size @n@. +-- +-- >>> pack (7 :: Unsigned 6) +-- 000111 +-- >>> split (7 :: Unsigned 6) :: (BitVector 2, BitVector 4) +-- (00,0111) +split :: (BitPack a, BitSize a ~ (m + n), KnownNat n) => a + -> (BitVector m, BitVector n) +split v = split# (pack v) + +{-# INLINE replaceBit #-} +-- | Set the bit at the specified index +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (-5 :: Signed 6) +-- 111011 +-- >>> replaceBit (-5 :: Signed 6) 4 0 +-- -21 +-- >>> pack (-21 :: Signed 6) +-- 101011 +-- >>> replaceBit (-5 :: Signed 6) 5 0 +-- 27 +-- >>> pack (27 :: Signed 6) +-- 011011 +-- >>> replaceBit (-5 :: Signed 6) 6 0 +-- *** Exception: replaceBit: 6 is out of range [5..0] +replaceBit :: (BitPack a, KnownNat (BitSize a), Integral i) => a -> i -> Bit + -> a +replaceBit v i b = unpack (replaceBit# (pack v) (fromIntegral i) b) + +{-# INLINE setSlice #-} +-- | Set the bits between bit index @m@ and bit index @n@. +-- +-- __NB:__ Bit indices are __DESCENDING__. +-- +-- >>> pack (-5 :: Signed 6) +-- 111011 +-- >>> setSlice (-5 :: Signed 6) d4 d3 0 +-- -29 +-- >>> pack (-29 :: Signed 6) +-- 100011 +-- >>> setSlice (-5 :: Signed 6) d6 d5 0 +-- :25:1: +-- Couldn't match type ‘7 + i0’ with ‘6’ +-- The type variable ‘i0’ is ambiguous +-- Expected type: (6 + 1) + i0 +-- Actual type: BitSize (Signed 6) +-- In the expression: setSlice (- 5 :: Signed 6) d6 d5 0 +-- In an equation for ‘it’: it = setSlice (- 5 :: Signed 6) d6 d5 0 +setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => a -> SNat m -> SNat n + -> BitVector (m + 1 - n) -> a +setSlice v m n w = unpack (setSlice# (pack v) m n w) + +{-# INLINE msb #-} +-- | Get the most significant bit. +-- +-- >>> pack (-4 :: Signed 6) +-- 111100 +-- >>> msb (-4 :: Signed 6) +-- 1 +-- >>> pack (4 :: Signed 6) +-- 000100 +-- >>> msb (4 :: Signed 6) +-- 0 +msb :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +msb v = msb# (pack v) + +{-# INLINE lsb #-} +-- | Get the least significant bit. +-- +-- >>> pack (-9 :: Signed 6) +-- 110111 +-- >>> lsb (-9 :: Signed 6) +-- 1 +-- >>> pack (-8 :: Signed 6) +-- 111000 +-- >>> lsb (-8 :: Signed 6) +-- 0 +lsb :: BitPack a => a -> Bit +lsb v = lsb# (pack v) diff --git a/src/CLaSH/Prelude/BitReduction.hs b/src/CLaSH/Prelude/BitReduction.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/BitReduction.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} + +module CLaSH.Prelude.BitReduction where + +import GHC.TypeLits (KnownNat) + +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Sized.Internal.BitVector (Bit, reduceAnd#, reduceOr#, reduceXor#) + +{-# INLINE reduceAnd #-} +-- | Are all bits set to '1'? +-- +-- >>> pack (-2 :: Signed 6) +-- 111110 +-- >>> reduceAnd (-2 :: Signed 6) +-- 0 +-- >>> pack (-1 :: Signed 6) +-- 111111 +-- >>> reduceAnd (-1 :: Signed 6) +-- 1 +reduceAnd :: (BitPack a, KnownNat (BitSize a)) => a -> Bit +reduceAnd v = reduceAnd# (pack v) + +{-# INLINE reduceOr #-} +-- | Is there at least one bit set to '1'? +-- +-- >>> pack (5 :: Signed 6) +-- 000101 +-- >>> reduceOr (5 :: Signed 6) +-- 1 +-- >>> pack (0 :: Signed 6) +-- 000000 +-- >>> reduceOr (0 :: Signed 6) +-- 0 +reduceOr :: BitPack a => a -> Bit +reduceOr v = reduceOr# (pack v) + +{-# INLINE reduceXor #-} +-- | Is the number of bits set to '1' uneven? +-- +-- >>> pack (5 :: Signed 6) +-- 000101 +-- >>> reduceXor (5 :: Signed 6) +-- 0 +-- >>> pack (28 :: Signed 6) +-- 011100 +-- >>> reduceXor (28 :: Signed 6) +-- 1 +-- >>> pack (-5 :: Signed 6) +-- 111011 +-- >>> reduceXor (-5 :: Signed 6) +-- 1 +reduceXor :: BitPack a => a -> Bit +reduceXor v = reduceXor# (pack v) diff --git a/src/CLaSH/Prelude/BlockRam.hs b/src/CLaSH/Prelude/BlockRam.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/BlockRam.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +module CLaSH.Prelude.BlockRam where + +import GHC.TypeLits (KnownNat, type (^)) +import Prelude hiding ((!!)) + +import CLaSH.Prelude.Mealy (cmealy) +import CLaSH.Signal (Signal) +import CLaSH.Signal.Explicit (CSignal, SClock, systemClock) +import CLaSH.Signal.Bundle (bundle) +import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.Sized.Vector (Vec, (!!), replace) + +{-# INLINE blockRam #-} +-- | Create a blockRAM with space for @n@ elements. +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- > bram40 :: Signal (Unsigned 6) -> Signal (Unsigned 6) -> Signal Bool +-- > -> Signal Bit -> Signal Bit +-- > bram40 = blockRam (replicate d40 H) +blockRam :: (KnownNat n, KnownNat m) + => Vec n a -- ^ Initial content of the BRAM, also + -- determines the size, @n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal (Unsigned m) -- ^ Write address @w@ + -> Signal (Unsigned m) -- ^ Read address @r@ + -> Signal Bool -- ^ Write enable + -> Signal a -- ^ Value to write (at address @w@) + -> Signal a + -- ^ Value of the 'blockRAM' at address @r@ from the previous clock + -- cycle +blockRam = cblockRam systemClock + +{-# INLINE blockRamPow2 #-} +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- > bram32 :: Signal (Unsigned 5) -> Signal (Unsigned 5) -> Signal Bool +-- > -> Signal Bit -> Signal Bit +-- > bram32 = blockRamPow2 (replicate d32 H) +blockRamPow2 :: (KnownNat (2^n), KnownNat n) + => Vec (2^n) a -- ^ Initial content of the BRAM, also + -- determines the size, @2^n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> Signal (Unsigned n) -- ^ Write address @w@ + -> Signal (Unsigned n) -- ^ Read address @r@ + -> Signal Bool -- ^ Write enable + -> Signal a -- ^ Value to write (at address @w@) + -> Signal a + -- ^ Value of the 'blockRAM' at address @r@ from the previous clock + -- cycle +blockRamPow2 = blockRam + +{-# NOINLINE cblockRam #-} +-- | Create a blockRAM with space for @n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- > +-- > bram40 :: CSignal ClkA (Unsigned 6) -> CSignal ClkA (Unsigned 6) +-- > -> CSignal ClkA Bool -> CSignal ClkA Bit -> ClkA CSignal Bit +-- > bram40 = cblockRam clkA100 (replicate d40 H) +cblockRam :: (KnownNat n, KnownNat m) + => SClock clk -- ^ 'Clock' to synchronize to + -> Vec n a -- ^ Initial content of the BRAM, also + -- determines the size, @n@, of the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> CSignal clk (Unsigned m) -- ^ Write address @w@ + -> CSignal clk (Unsigned m) -- ^ Read address @r@ + -> CSignal clk Bool -- ^ Write enable + -> CSignal clk a -- ^ Value to write (at address @w@) + -> CSignal clk a + -- ^ Value of the 'blockRAM' at address @r@ from the previous clock + -- cycle +cblockRam clk binit wr rd en din = + cmealy clk bram' (binit,undefined) (bundle clk (wr,rd,en,din)) + where + bram' (ram,o) (w,r,e,d) = ((ram',o'),o) + where + ram' | e = replace ram w d + | otherwise = ram + o' = ram !! r + +{-# INLINE cblockRamPow2 #-} +-- | Create a blockRAM with space for 2^@n@ elements +-- +-- * __NB__: Read value is delayed by 1 cycle +-- * __NB__: Initial output value is 'undefined' +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- > +-- > bramC32 :: CSignal ClkA (Unsigned 5) -> CSignal ClkA (Unsigned 5) +-- > -> CSignal ClkA Bool -> CSignal ClkA Bit -> CSignal ClkA Bit +-- > bramC32 = cblockRamPow2 clkA100 (replicate d32 H) +cblockRamPow2 :: (KnownNat n, KnownNat (2^n)) + => SClock clk -- ^ 'Clock' to synchronize to + -> Vec (2^n) a -- ^ Initial content of the BRAM, also + -- determines the size, @2^n@, of + -- the BRAM. + -- + -- __NB__: __MUST__ be a constant. + -> CSignal clk (Unsigned n) -- ^ Write address @w@ + -> CSignal clk (Unsigned n) -- ^ Read address @r@ + -> CSignal clk Bool -- ^ Write enable + -> CSignal clk a -- ^ Value to write (at address @w@) + -> CSignal clk a + -- ^ Value of the 'blockRAM' at address @r@ from the previous + -- clock cycle +cblockRamPow2 = cblockRam diff --git a/src/CLaSH/Prelude/DataFlow.hs b/src/CLaSH/Prelude/DataFlow.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/DataFlow.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Self-synchronising circuits based on data-flow principles. +module CLaSH.Prelude.DataFlow + ( -- * Data types + DataFlow + , DataFlow' + , df + -- * Creating DataFlow circuits + , liftDF + , mealyDF + -- * Composition combinators + , idDF + , seqDF + , firstDF + , swapDF + , secondDF + , parDF + , loopDF + -- * Lock-Step operation + , lockStep + , stepLock + ) +where + +import Data.Functor ((<$>)) +import Control.Applicative (Applicative (..)) +import GHC.TypeLits (KnownNat, KnownSymbol) + +import CLaSH.Signal ((.&&.), regEn, unbundle') +import CLaSH.Signal.Bundle (Bundle (..)) +import CLaSH.Signal.Explicit (Clock (..), CSignal, SystemClock, sclock) + +{- | Dataflow circuit with bidirectional synchronisation channels. + +In the /forward/ direction we assert /validity/ of the data. In the /backward/ +direction we assert that the circuit is /ready/ to receive new data. A circuit +adhering to the 'DataFlow' type should: + + * Not consume data when validity is deasserted. + * Only update its output when readiness is asserted. + +The 'DataFlow' type is defined as: + +@ +newtype DataFlow clk iEn oEn i o + = DF + { df :: CSignal clk i -- Incoming data + -> CSignal clk iEn -- Flagged with /valid/ bits @iEn@. + -> CSignal clk oEn -- Incoming back-pressure, /ready/ edge. + -> ( CSignal clk o -- Outgoing data. + , CSignal clk oEn -- Flagged with /valid/ bits @oEn@. + , CSignal clk iEn -- Outgoing back-pressure, /ready/ edge. + ) + } +@ + +where: + + * @clk@ is the clock to which the circuit is synchronised. + * @iEn@ is the type of the bidirectional incoming synchronisation channel. + * @oEn@ is the type of the bidirectional outgoing synchronisation channel. + * @i@ is the incoming data type. + * @o@ is the outgoing data type. + +We define several composition operators for our 'DataFlow' circuits: + + * 'seqDF' sequential composition. + * 'parDF' parallel composition. + * 'loopDF' add a feedback arc. + * 'lockStep' proceed in lock-step. + +When you look at the types of the above operators it becomes clear why we +parametrise in the types of the synchronisation channels. +-} +newtype DataFlow clk iEn oEn i o + = DF + { -- | Create an ordinary circuit from a 'DataFlow' circuit + df :: CSignal clk i -- Incoming data + -> CSignal clk iEn -- Flagged with /valid/ bits @iEn@. + -> CSignal clk oEn -- Incoming back-pressure, /ready/ edge. + -> ( CSignal clk o -- Outgoing data. + , CSignal clk oEn -- Flagged with /valid/ bits @oEn@. + , CSignal clk iEn -- Outgoing back-pressure, /ready/ edge. + ) + } + +-- | Dataflow circuit synchronised to the 'SystemClock'. +type DataFlow' iEn oEn i o = DataFlow SystemClock iEn oEn i o + +-- | Create a 'DataFlow' circuit from a circuit description with the appropriate +-- type: +-- +-- > CSignal clk i -- Incoming data. +-- > -> CSignal clk Bool -- Flagged with a single /valid/ bit. +-- > -> CSignal clk Bool -- Incoming back-pressure, /ready/ bit. +-- > -> ( CSignal clk o -- Outgoing data. +-- > , CSignal clk oEn -- Flagged with a single /valid/ bit. +-- > , CSignal clk iEn -- Outgoing back-pressure, /ready/ bit. +-- > ) +-- +-- A circuit adhering to the 'DataFlow' type should: +-- +-- * Not consume data when validity is deasserted. +-- * Only update its output when readiness is asserted. +liftDF :: (CSignal clk i -> CSignal clk Bool -> CSignal clk Bool + -> (CSignal clk o, CSignal clk Bool, CSignal clk Bool)) + -> DataFlow clk Bool Bool i o +liftDF = DF + +-- | Create a 'DataFlow' circuit from a Mealy machine description as those of +-- "CLaSH.Prelude.Mealy" +mealyDF :: (s -> i -> (s,o)) + -> s + -> DataFlow' Bool Bool i o +mealyDF f iS = DF (\i iV oR -> let en = iV .&&. oR + (s',o) = unbundle' (f <$> s <*> i) + s = regEn iS en s' + in (o,iV,oR)) + +-- | Identity circuit +-- +-- <> +idDF :: DataFlow clk en en a a +idDF = DF (\a val rdy -> (a,val,rdy)) + +-- | Sequential composition of two 'DataFlow' circuits. +-- +-- <> +seqDF :: DataFlow clk aEn bEn a b + -> DataFlow clk bEn cEn b c + -> DataFlow clk aEn cEn a c +(DF f) `seqDF` (DF g) = DF (\a aVal cRdy -> let (b,bVal,aRdy) = f a aVal bRdy + (c,cVal,bRdy) = g b bVal cRdy + in (c,cVal,aRdy)) + +-- | Apply the circuit to the first halve of the communication channels, leave +-- the second halve unchanged. +-- +-- <> +firstDF :: (KnownSymbol nm, KnownNat rate) + => DataFlow (Clk nm rate) aEn bEn a b + -> DataFlow (Clk nm rate) (aEn,cEn) (bEn,cEn) (a,c) (b,c) +firstDF (DF f) = DF (\ac acV bcR -> let clk = sclock + (a,c) = unbundle clk ac + (aV,cV) = unbundle clk acV + (bR,cR) = unbundle clk bcR + (b,bV,aR) = f a aV bR + bc = bundle clk (b,c) + bcV = bundle clk (bV,cV) + acR = bundle clk (aR,cR) + in (bc,bcV,acR) + ) + +-- | Swap the two communication channels. +-- +-- <> +swapDF :: (KnownSymbol nm, KnownNat rate) + => DataFlow (Clk nm rate) (aEn,bEn) (bEn,aEn) (a,b) (b,a) +swapDF = DF (\ab abV baR -> (swap <$> ab, swap <$> abV, swap <$> baR)) + where + swap ~(a,b) = (b,a) + +-- | Apply the circuit to the second halve of the communication channels, leave +-- the first halve unchanged. +-- +-- <> +secondDF :: (KnownSymbol nm, KnownNat rate) + => DataFlow (Clk nm rate) aEn bEn a b + -> DataFlow (Clk nm rate) (cEn,aEn) (cEn,bEn) (c,a) (c,b) +secondDF f = swapDF `seqDF` firstDF f `seqDF` swapDF + +-- | Compose two 'DataFlow' circuits in parallel. +-- +-- <> +parDF :: (KnownSymbol nm, KnownNat rate) + => DataFlow (Clk nm rate) aEn bEn a b + -> DataFlow (Clk nm rate) cEn dEn c d + -> DataFlow (Clk nm rate) (aEn,cEn) (bEn,dEn) (a,c) (b,d) +f `parDF` g = firstDF f `seqDF` secondDF g + +-- | Feed back the second halve of the communication channel. +-- +-- Given: +-- +-- > f `seqDF` (loopDF h) `seqDF` g +-- +-- The circuits @f@, @h@, and @g@, will operate in /lock-step/. Which means that +-- there it only progress when all three circuits are producing /valid/ data +-- and all three circuits are /ready/ to receive new data. The 'loopDF' function +-- uses the 'lockStep' and 'stepLock' functions to achieve the /lock-step/ +-- operation. +-- +-- <> +loopDF :: forall nm rate a b d . (KnownSymbol nm, KnownNat rate) + => DataFlow (Clk nm rate) Bool Bool (a,d) (b,d) + -> DataFlow (Clk nm rate) Bool Bool a b +loopDF f = loopDF' h + where + h :: DataFlow (Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) + h = lockStep `seqDF` f `seqDF` stepLock + + loopDF' :: DataFlow (Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) + -> DataFlow (Clk nm rate) Bool Bool a b + loopDF' (DF f') = DF (\a aV bR -> let clk = sclock + (bd,bdV,adR) = f' ad adV bdR + (b,d) = unbundle clk bd + (bV,dV) = unbundle clk bdV + (aR,dR) = unbundle clk adR + ad = bundle clk (a,d) + adV = bundle clk (aV,dV) + bdR = bundle clk (bR,dR) + in (b,bV,aR) + ) + +-- | Have parallel compositions operate in lock-step. +class LockStep a b where + -- | Reduce the synchronisation granularity to a single 'Bool'ean value. + -- + -- Given: + -- + -- > f :: DataFlow' Bool Bool a b + -- > g :: DataFlow' Bool Bool c d + -- > h :: DataFlow' Bool Bool (b,d) (p,q) + -- + -- We /cannot/ simply write: + -- + -- > (f `parDF` g) `seqDF` h + -- + -- because, @f \`parDF\` g@, has type, @DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, + -- which does not match the expected synchronisation granularity of @h@. We + -- need a circuit in between that has the type: + -- + -- > DataFlow' (Bool,Bool) Bool (b,d) (b,d) + -- + -- Simply '&&'-ing the /valid/ signals in the forward direction, and + -- duplicating the /ready/ signal in the backward direction is however not + -- enough. We also need to make sure that @f@ does not update its output when + -- @g@'s output is invalid and visa versa, as @h@ can only consume its input + -- when both @f@ and @g@ are producing valid data. @g@'s /ready/ port is hence + -- only asserted when @h@ is ready and @f@ is producing /valid/ data. And @f@'s + -- ready port is only asserted when @h@ is ready and @g@ is producing valid + -- data. @f@ and @g@ will hence be proceeding in /lock-step/. + -- + -- The 'lockStep' function ensures that all synchronisation signals are + -- properly connected: + -- + -- > (f `parDF` g) `seqDF` lockStep `seqDF` h + -- + -- <> + -- + -- Note that 'lockStep' works for arbitrarily nested tuples. That is: + -- + -- > p :: DataFlow' Bool Bool ((b,d),d) z + -- > + -- > q :: Dataflow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) + -- > q = f `parDF` g `parDf` g + -- > + -- > r = q `seqDF` lockStep `seqDF` p + -- + -- Does the right thing. + lockStep :: (KnownNat rate,KnownSymbol nm) + => DataFlow (Clk nm rate) a Bool b b + + -- | Extend the synchronisation granularity from a single 'Bool'ean value. + -- + -- Given: + -- + -- > f :: DataFlow' Bool Bool a b + -- > g :: DataFlow' Bool Bool c d + -- > h :: DataFlow' Bool Bool (p,q) (a,c) + -- + -- We /cannot/ simply write: + -- + -- > h `seqDF` (f `parDF` g) + -- + -- because, @f \`parDF\` g@, has type, @DataFlow' (Bool,Bool) (Bool,Bool) (a,c) (b,d)@, + -- which does not match the expected synchronisation granularity of @h@. We + -- need a circuit in between that has the type: + -- + -- > DataFlow' Bool (Bool,Bool) (a,c) (a,c) + -- + -- Simply '&&'-ing the /ready/ signals in the backward direction, and + -- duplicating the /valid/ signal in the forward direction is however not + -- enough. We need to make sure that @f@ does not consume values when @g@ is + -- not /ready/ and visa versa, because @h@ cannot update the values of its + -- output tuple independently. @f@'s /valid/ port is hence only asserted when + -- @h@ is valid and @g@ is ready to receive new values. @g@'s /valid/ port is + -- only asserted when @h@ is valid and @f@ is ready to receive new values. + -- @f@ and @g@ will hence be proceeding in /lock-step/. + -- + -- The 'stepLock' function ensures that all synchronisation signals are + -- properly connected: + -- + -- > h `seqDF` stepLock `seqDF` (f `parDF` g) + -- + -- <> + -- + -- Note that 'stepLock' works for arbitrarily nested tuples. That is: + -- + -- > p :: DataFlow' Bool Bool z ((a,c),c) + -- > + -- > q :: Dataflow' ((Bool,Bool),Bool) ((Bool,Bool),Bool) ((a,c),c) ((b,d),d) + -- > q = f `parDF` g `parDf` g + -- > + -- > r = p `seqDF` lockStep` `seqDF` q + -- + -- Does the right thing. + stepLock :: (KnownNat rate,KnownSymbol nm) + => DataFlow (Clk nm rate) Bool a b b + +instance LockStep Bool c where + lockStep = idDF + stepLock = idDF + +instance (LockStep a x, LockStep b y) => LockStep (a,b) (x,y) where + lockStep = (lockStep `parDF` lockStep) `seqDF` + (DF (\xy xyV rdy -> let clk = sclock + (xV,yV) = unbundle clk xyV + val = xV .&&. yV + xR = yV .&&. rdy + yR = xV .&&. rdy + xyR = bundle clk (xR,yR) + in (xy,val,xyR))) + + stepLock = (DF (\xy val xyR -> let clk = sclock + (xR,yR) = unbundle clk xyR + rdy = xR .&&. yR + xV = val .&&. yR + yV = val .&&. xR + xyV = bundle clk (xV,yV) + in (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock) + diff --git a/src/CLaSH/Prelude/Explicit.hs b/src/CLaSH/Prelude/Explicit.hs --- a/src/CLaSH/Prelude/Explicit.hs +++ b/src/CLaSH/Prelude/Explicit.hs @@ -1,10 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -O0 -fno-omit-interface-pragmas #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} {- | This module defines the explicitly clocked counterparts of the functions @@ -17,21 +13,17 @@ -} module CLaSH.Prelude.Explicit ( -- * Creating synchronous sequential circuits - sync - , cregisterP - -- * 'Arrow' interface for synchronous sequential circuits - , CComp (..) - , syncA - , cregisterC - , csimulateC + cmealy + , cmealyB + , cregisterB -- * BlockRAM primitives , cblockRam , cblockRamPow2 - , blockRamCC - , blockRamPow2CC -- * Utility functions , cwindow , cwindowD + , cisRising + , cisFalling -- * Testbench functions , csassert , cstimuliGenerator @@ -42,230 +34,30 @@ ) where -import Data.Default (Default (..)) -import Debug.Trace (trace) -import Control.Applicative (Applicative (..), (<$>),liftA3) -import Control.Arrow (Arrow (..), ArrowLoop (..)) -import Control.Category as Category -import GHC.TypeLits (KnownNat,type (^), type (+)) +import Control.Applicative (liftA2) +import Data.Default (Default (..)) +import GHC.TypeLits (KnownNat, type (+), natVal) +import Prelude hiding (repeat) -import CLaSH.Promoted.Nat (snat) +import CLaSH.Prelude.BlockRam (cblockRam, cblockRamPow2) +import CLaSH.Prelude.Mealy (cmealy, cmealyB) +import CLaSH.Prelude.Testbench (csassert, cstimuliGenerator, coutputVerifier) import CLaSH.Signal.Explicit -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec (..), (!), (+>>), maxIndex, vcopyI, vreplace) - -{-# INLINABLE sync #-} --- | Create a synchronous function from a combinational function describing --- a mealy machine --- --- > mac :: Int -- Current state --- > -> (Int,Int) -- Input --- > -> (Int,Int) -- (Updated state, output) --- > mac s (x,y) = (s',s) --- > where --- > s' = x * y + s --- > --- > clk100 = Clock d100 --- > --- > topEntity :: (CSignal 100 Int, CSignal 100 Int) -> CSignal 100 Int --- > topEntity = sync clk100 mac 0 --- --- >>> csimulateP clk100 clk100 topEntity [(1,1),(2,2),(3,3),(4,4),... --- [0,1,5,14,30,... --- --- Synchronous sequential functions can be composed just like their combinational counterpart: --- --- > dualMac :: (CSignal 100 Int, CSignal 100 Int) --- > -> (CSignal 100 Int, CSignal 100 Int) --- > -> CSignal 100 Int --- > dualMac (a,b) (x,y) = s1 + s2 --- > where --- > s1 = sync clk100 mac 0 (a,b) --- > s2 = sync clk100 mac 0 (x,y) -sync :: (CPack i, CPack o) - => Clock clk -- ^ 'Clock' to synchronize to - -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> (CSignalP clk i -> CSignalP clk o) -- ^ Synchronous sequential function with input and output matching that of the mealy machine -sync clk f iS = \i -> let (s',o) = cunpack clk $ f <$> s <*> cpack clk i - s = cregister clk iS s' - in cunpack clk o +import CLaSH.Sized.Vector (Vec (..), (+>>), asNatProxy, repeat) -{-# INLINABLE cregisterP #-} --- | Create a 'register' function for product-type like signals (e.g. '(Signal a, Signal b)') +{-# INLINE cregisterB #-} +-- | Create a 'register' function for product-type like signals (e.g. +-- '(Signal a, Signal b)') -- -- > clk100 = Clock d100 -- > -- > rP :: (CSignal 100 Int, CSignal 100 Int) -> (CSignal 100 Int, CSignal 100 Int) --- > rP = cregisterP d100 (8,8) --- --- >>> csimulateP clk100 clk100 rP [(1,1),(2,2),(3,3),... --- [(8,8),(1,1),(2,2),(3,3),... -cregisterP :: CPack a => Clock clk -> a -> CSignalP clk a -> CSignalP clk a -cregisterP clk i = cunpack clk Prelude.. cregister clk i Prelude.. cpack clk - -{-# DEPRECATED CComp "Will be removed in version 0.6. Use 'Applicative' interface and 'sync' instead" #-} --- | 'CComp'onent: an 'Arrow' interface to explicitly clocked synchronous --- sequential functions -newtype CComp t a b = CC { asCFunction :: CSignal t a -> CSignal t b } - -instance Category (CComp t) where - id = CC Prelude.id - (CC f) . (CC g) = CC (f Prelude.. g) - -instance KnownNat t => Arrow (CComp t) where - arr = CC Prelude.. fmap - first (CC f) = let clk = Clock snat - in CC $ cpack clk Prelude.. (f >< Prelude.id) Prelude.. cunpack clk - where - (g >< h) (x,y) = (g x,h y) - -instance KnownNat t => ArrowLoop (CComp t) where - loop (CC f) = let clk = Clock snat - in CC $ simpleLoop (cunpack clk Prelude.. f Prelude.. cpack clk) - where - simpleLoop g b = let ~(c,d) = g (b,d) - in c - -{-# DEPRECATED syncA "Will be removed in version 0.6. Use 'Applicative' interface and 'sync' instead" #-} -{-# INLINABLE syncA #-} --- | Create a synchronous 'CComp'onent from a combinational function describing --- a mealy machine --- --- > mac :: Int -- Current state --- > -> (Int,Int) -- Input --- > -> (Int,Int) -- (Updated state, output) --- > mac s (x,y) = (s',s) --- > where --- > s' = x * y + s --- > --- > clk100 = Clock d100 --- > --- > topEntity :: CComp 100 (Int,Int) Int --- > topEntity = syncA clk100 mac 0 --- --- >>> simulateC topEntity [(1,1),(2,2),(3,3),(4,4),... --- [0,1,5,14,30,... --- --- Synchronous sequential must be composed using the 'Arrow' syntax --- --- > dualMac :: CComp 100 (Int,Int,Int,Int) Int --- > dualMac = proc (a,b,x,y) -> do --- > rec s1 <- syncA clk100 mac 0 -< (a,b) --- > s2 <- syncA clk100 mac 0 -< (x,y) --- > returnA -< (s1 + s2) -syncA :: Clock clk -- ^ 'Clock' to synchronize to - -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: @state -> input -> (newstate,output)@ - -> s -- ^ Initial state - -> CComp clk i o -- ^ Synchronous sequential 'Comp'onent with input and output matching that of the mealy machine -syncA clk f sI = CC $ \i -> let (s',o) = cunpack clk $ f <$> s <*> i - s = cregister clk sI s' - in o - -{-# DEPRECATED cregisterC "'CComp' is deprecated and will be removed in version 0.6, use 'cregister' instead" #-} --- | Create a 'cregister' 'CComp'onent --- --- > clk100 = Clock d100 --- > --- > rC :: CComp 100 (Int,Int) (Int,Int) --- > rC = cregisterC clk100 (8,8) +-- > rP = cregisterB d100 (8,8) -- --- >>> simulateC rP [(1,1),(2,2),(3,3),... +-- >>> csimulateB clk100 clk100 rP [(1,1),(2,2),(3,3),... -- [(8,8),(1,1),(2,2),(3,3),... -cregisterC :: Clock clk -> a -> CComp clk a a -cregisterC clk = CC Prelude.. cregister clk - -{-# DEPRECATED csimulateC "'CComp' is deprecated and will be removed in version 0.6, use 'csimulate' instead" #-} --- | Simulate a 'Comp'onent given a list of samples --- --- > clk100 = Clock d100 --- >>> csimulateC (cregisterC clk100 8) [1, 2, 3, ... --- [8, 1, 2, 3, ... -csimulateC :: CComp clk a b -> [a] -> [b] -csimulateC f = csimulate (asCFunction f) - -{-# NOINLINE cblockRam #-} --- | Create a blockRAM with space for @n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > clk100 = Clock d100 --- > --- > bram40 :: CSignal 100 (Unsigned 6) -> CSignal 100 (Unsigned 6) --- > -> CSignal 100 Bool -> CSignal 100 Bit -> 100 CSignal Bit --- > bram40 = cblockRam clk100 (vcopy d40 H) -cblockRam :: (CPack a, KnownNat n, KnownNat m) - => Clock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ Initial content of the BRAM, also determines the size ,@n@, of the BRAM. - -- NB: *MUST* be a constant. - -> CSignal clk (Unsigned m) -- ^ Write address @w@ - -> CSignal clk (Unsigned m) -- ^ Read address @r@ - -> CSignal clk Bool -- ^ Write enable - -> CSignal clk a -- ^ Value to write (at address @w@) - -> CSignal clk a -- ^ Value of the 'blockRAM' at address @r@ from the previous clock cycle -cblockRam clk binit wr rd en din = cpack clk $ (sync clk bram' (binit,undefined)) (wr,rd,en,din) - where - bram' (ram,o) (w,r,e,d) = ((ram',o'),o) - where - ram' | e = vreplace ram w d - | otherwise = ram - o' = ram ! r - -{-# DEPRECATED blockRamCC "'CComp' is deprecated and will be removed in version 0.6, use 'cblockRam' instead" #-} --- | Create a blockRAM with space for @n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > clk100 = Clock d100 --- > --- > bramC40 :: CComp 100 (Unsigned 6, Unsigned 6, Bool, Bit) Bit --- > bramC40 = blockRamCC clk100 (vcopy d40 H) -blockRamCC :: (KnownNat n, KnownNat m, CPack a, Default a) - => Clock clk -- ^ 'Clock' to synchronize to - -> Vec n a -- ^ Initial content of the BRAM, also determines the size ,@n@, of the BRAM. - -- NB: *MUST* be a constant. - -> CComp clk (Unsigned m, Unsigned m, Bool, a) a -blockRamCC clk n = CC ((\(wr,rd,en,din) -> cblockRam clk n wr rd en din) Prelude.. cunpack clk) - -{-# INLINABLE cblockRamPow2 #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > clk100 = Clock d100 --- > --- > bramC32 :: CSignal 100 (Unsigned 5) -> CSignal 100 (Unsigned 5) -> CSignal 100 Bool -> CSignal 100 Bit -> CSignal 100 Bit --- > bramC32 = cblockRamPow2 clk100 (vcopy d32 H) -cblockRamPow2 :: (KnownNat n, KnownNat (2^n), CPack a) - => Clock clk -- ^ 'Clock' to synchronize to - -> Vec (2^n) a -- ^ Initial content of the BRAM, also determines the size ,@2^n@, of the BRAM. - -- NB: *MUST* be a constant. - -> CSignal clk (Unsigned n) -- ^ Write address @w@ - -> CSignal clk (Unsigned n) -- ^ Read address @r@ - -> CSignal clk Bool -- ^ Write enable - -> CSignal clk a -- ^ Value to write (at address @w@) - -> CSignal clk a -- ^ Value of the 'blockRAM' at address @r@ from the previous clock cycle -cblockRamPow2 = cblockRam - -{-# DEPRECATED blockRamPow2CC "'CComp' is deprecated and will be removed in version 0.6, use 'cblockRamPow2' instead" #-} --- | Create a blockRAM with space for 2^@n@ elements --- --- * NB: Read value is delayed by 1 cycle --- * NB: Initial output value is `undefined` --- --- > clk100 = Clock d100 --- > --- > bramC32 :: CComp 100 (Unsigned 5, Unsigned 5, Bool, Bit) Bit --- > bramC32 = blockRamPow2CC clk100 (vcopy d32 Bit) -blockRamPow2CC :: (KnownNat n, KnownNat (2^n), CPack a) - => Clock clk -- ^ 'Clock' to synchronize to - -> Vec (2^n) a -- ^ Initial content of the BRAM, also determines the size ,@2^n@, of the BRAM. - -- NB: *MUST* be a constant. - -> CComp clk (Unsigned n, Unsigned n, Bool, a) a -blockRamPow2CC clk n = CC ((\(wr,rd,en,din) -> cblockRamPow2 clk n wr rd en din) Prelude.. cunpack clk) +cregisterB :: Bundle a => SClock clk -> a -> Unbundled clk a -> Unbundled clk a +cregisterB clk i = unbundle clk Prelude.. cregister clk i Prelude.. bundle clk {-# INLINABLE cwindow #-} -- | Give a window over a 'CSignal' @@ -273,16 +65,20 @@ -- > window4 :: Signal Int -> Vec 4 (Signal Int) -- > window4 = window -- --- >>> csimulateP window4 [1,2,3,4,5,... +-- >>> csimulateB window4 [1,2,3,4,5,... -- [<1,0,0,0>, <2,1,0,0>, <3,2,1,0>, <4,3,2,1>, <5,4,3,2>,... -cwindow :: (KnownNat (n + 1), Default a) - => Clock clk -- ^ Clock to which the incoming signal is synchronized - -> CSignal clk a -- ^ Signal to create a window over - -> Vec ((n + 1) + 1) (CSignal clk a) -- ^ Window of at least size 2 -cwindow clk x = x :> prev +cwindow :: (KnownNat n, Default a) + => SClock clk -- ^ Clock to which the incoming + -- signal is synchronized + -> CSignal clk a -- ^ Signal to create a window over + -> Vec (n + 1) (CSignal clk a) -- ^ Window of at least size 1 +cwindow clk x = res where - prev = cregisterP clk (vcopyI def) next - next = x +>> prev + res = x :> prev + prev = case natVal (asNatProxy prev) of + 0 -> repeat def + _ -> let next = x +>> prev + in cregisterB clk (repeat def) next {-# INLINABLE cwindowD #-} -- | Give a delayed window over a 'CSignal' @@ -290,117 +86,38 @@ -- > windowD3 :: Signal Int -> Vec 3 (Signal Int) -- > windowD3 = windowD -- --- >>> csimulateP windowD3 [1,2,3,4,... +-- >>> csimulateB windowD3 [1,2,3,4,... -- [<0,0,0>, <1,0,0>, <2,1,0>, <3,2,1>, <4,3,2>,... cwindowD :: (KnownNat (n + 1), Default a) - => Clock clk -- ^ Clock to which the incoming signal is synchronized - -> CSignal clk a -- ^ Signal to create a window over - -> Vec (n + 1) (CSignal clk a) -- ^ Window of at least size 1 + => SClock clk -- ^ Clock to which the incoming signal + -- is synchronized + -> CSignal clk a -- ^ Signal to create a window over + -> Vec (n + 1) (CSignal clk a) -- ^ Window of at least size 1 cwindowD clk x = prev where - prev = cregisterP clk (vcopyI def) next + prev = cregisterB clk (repeat def) next next = x +>> prev -{-# NOINLINE csassert #-} --- | Compares the first two arguments for equality and logs a warning when they --- are not equal. The second argument is considered the expected value. This --- function simply returns the third argument unaltered as its result. This --- function is used by 'coutputVerifier'. --- --- --- This function is translated to the following VHDL: --- --- > csassert_block : block --- > begin --- > -- pragma translate_off --- > process(clk_t,reset_t,arg0,arg1) is --- > begin --- > if (rising_edge(clk_t) or rising_edge(reset_t)) then --- > assert (arg0 = arg1) report ("expected: " & to_string (arg1) & \", actual: \" & to_string (arg0)) severity error; --- > end if; --- > end process; --- > -- pragma translate_on --- > result <= arg2; --- > end block; --- --- And can, due to the pragmas, be used in synthesizable designs -csassert :: (Eq a,Show a) - => CSignal t a -- ^ Checked value - -> CSignal t a -- ^ Expected value - -> CSignal t b -- ^ Return valued - -> CSignal t b -csassert = liftA3 - (\a' b' c' -> if a' == b' then c' - else trace ("\nexpected value: " ++ show b' ++ ", not equal to actual value: " ++ show a') c') - -{-# INLINABLE cstimuliGenerator #-} --- | To be used as a one of the functions to create the \"magical\" 'testInput' --- value, which the CλaSH compilers looks for to create the stimulus generator --- for the generated VHDL testbench. --- --- Example: --- --- > clk2 = Clock d2 --- > --- > testInput :: CSignal 2 Int --- > testInput = cstimuliGenerator $(v [(1::Int),3..21]) clk2 --- --- >>> csample testInput --- [1,3,5,7,9,11,13,15,17,19,21,21,21,... -cstimuliGenerator :: forall l clk a . KnownNat l - => Vec l a -- ^ Samples to generate - -> Clock clk -- ^ Clock to synchronize the output signal to - -> CSignal clk a -- ^ Signal of given samples -cstimuliGenerator samples clk = - let (r,o) = cunpack clk (genT <$> cregister clk (fromInteger (maxIndex samples)) r) - in o +{-# INLINABLE cisRising #-} +-- | Give a pulse when the 'CSignal' goes from 'minBound' to 'maxBound' +cisRising :: (Bounded a, Eq a) + => SClock clk + -> a -- ^ Starting value + -> CSignal clk a + -> CSignal clk Bool +cisRising clk is s = liftA2 edgeDetect prev s where - genT :: Unsigned l -> (Unsigned l,a) - genT s = (s',samples ! s) - where - s' = if s > 0 then s - 1 - else s + prev = cregister clk is s + edgeDetect old new = old == minBound && new == maxBound -{-# INLINABLE coutputVerifier #-} --- | To be used as a functions to generate the \"magical\" 'expectedOutput' --- function, which the CλaSH compilers looks for to create the signal verifier --- for the generated VHDL testbench. --- --- Example: --- --- > clk7 = Clock d7 --- > --- > expectedOutput :: CSignal 7 Int -> CSignal 7 Bool --- > expectedOutput = coutputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) clk7 --- --- >>> csample (expectedOutput (cfromList ([0..10] ++ [10,10,10]))) --- [ --- expected value: 70, not equal to actual value: 0 --- False, --- expected value: 99, not equal to actual value: 1 --- False,False,False,False,False, --- expected value: 7, not equal to actual value: 6 --- False, --- expected value: 8, not equal to actual value: 7 --- False, --- expected value: 9, not equal to actual value: 8 --- False, --- expected value: 10, not equal to actual value: 9 --- False,True,True,... -coutputVerifier :: forall l clk a . (KnownNat l, Eq a, Show a) - => Vec l a -- ^ Samples to compare with - -> Clock clk -- ^ Clock the input signal is synchronized to - -> CSignal clk a -- ^ Signal to verify - -> CSignal clk Bool -- ^ Indicator that all samples are verified -coutputVerifier samples clk i = - let (s,o) = cunpack clk (genT <$> cregister clk (fromInteger (maxIndex samples)) s) - (e,f) = cunpack clk o - in csassert i e (cregister clk False f) +{-# INLINABLE cisFalling #-} +-- | Give a pulse when the 'CSignal' goes from 'maxBound' to 'minBound' +cisFalling :: (Bounded a, Eq a) + => SClock clk + -> a -- ^ Starting value + -> CSignal clk a + -> CSignal clk Bool +cisFalling clk is s = liftA2 edgeDetect prev s where - genT :: Unsigned l -> (Unsigned l,(a,Bool)) - genT s = (s',(samples ! s,finished)) - where - s' = if s >= 1 then s - 1 - else s - - finished = s == 0 + prev = cregister clk is s + edgeDetect old new = old == maxBound && new == minBound diff --git a/src/CLaSH/Prelude/Mealy.hs b/src/CLaSH/Prelude/Mealy.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/Mealy.hs @@ -0,0 +1,167 @@ +module CLaSH.Prelude.Mealy + ( -- * Mealy machine synchronised to the system clock + mealy + , mealyB + , (<^>) + -- * Mealy machine synchronised to an arbitrary clock + , cmealy + , cmealyB + ) +where + +import Control.Applicative ((<$>), (<*>)) + +import CLaSH.Signal (Signal, Unbundled') +import CLaSH.Signal.Explicit (CSignal, SClock, cregister, systemClock) +import CLaSH.Signal.Bundle (Bundle (..), Unbundled) + +{-# INLINE mealy #-} +-- | Create a synchronous function from a combinational function describing +-- a mealy machine +-- +-- > mac :: Int -- Current state +-- > -> (Int,Int) -- Input +-- > -> (Int,Int) -- (Updated state, output) +-- > mac s (x,y) = (s',s) +-- > where +-- > s' = x * y + s +-- > +-- > topEntity :: Signal (Int, Int) -> Signal Int +-- > topEntity = mealy mac 0 +-- +-- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4),... +-- [0,1,5,14,30,... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- > dualMac :: (Signal Int, Signal Int) +-- > -> (Signal Int, Signal Int) +-- > -> Signal Int +-- > dualMac (a,b) (x,y) = s1 + s2 +-- > where +-- > s1 = mealy mac 0 (bundle' (a,x)) +-- > s2 = mealy mac 0 (bundle' (b,y)) +mealy :: (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Signal i -> Signal o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealy = cmealy systemClock + +{-# INLINE mealyB #-} +-- | A version of 'mealy' that does automatic 'Bundle'ing +-- +-- Given a function @f@ of type: +-- +-- > f :: Int -> (Bool, Int) -> (Int, (Int, Bool)) +-- +-- When we want to make compositions of @f@ in @g@ using 'mealy', we have to +-- write: +-- +-- @ +-- g a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'CLaSH.Signal.unbundle'' (mealy f 0 ('CLaSH.Signal.bundle'' (a,b))) +-- (i2,b2) = 'CLaSH.Signal.unbundle'' (mealy f 3 ('CLaSH.Signal.bundle'' (i1,c))) +-- @ +-- +-- Using 'mealyB' however we can write: +-- +-- > g a b c = (b1,b2,i2) +-- > where +-- > (i1,b1) = mealyB f 0 (a,b) +-- > (i2,b2) = mealyB f 3 (i1,c) +mealyB :: (Bundle i, Bundle o) + => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled' i -> Unbundled' o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +mealyB = cmealyB systemClock + +{-# INLINE (<^>) #-} +-- | Infix version of 'mealyB' +(<^>) :: (Bundle i, Bundle o) + => (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled' i -> Unbundled' o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +(<^>) = mealyB + +{-# INLINABLE cmealy #-} +-- | Create a synchronous function from a combinational function describing +-- a mealy machine +-- +-- > mac :: Int -- Current state +-- > -> (Int,Int) -- Input +-- > -> (Int,Int) -- (Updated state, output) +-- > mac s (x,y) = (s',s) +-- > where +-- > s' = x * y + s +-- > +-- > clk100 = Clock d100 +-- > +-- > topEntity :: CSignal 100 (Int, Int) -> CSignal 100 Int +-- > topEntity = cmealy clk100 mac 0 +-- +-- >>> csimulate clk100 clk100 topEntity [(1,1),(2,2),(3,3),(4,4),... +-- [0,1,5,14,30,... +-- +-- Synchronous sequential functions can be composed just like their +-- combinational counterpart: +-- +-- > dualMac :: (CSignal 100 Int, CSignal 100 Int) +-- > -> (CSignal 100 Int, CSignal 100 Int) +-- > -> CSignal 100 Int +-- > dualMac (a,b) (x,y) = s1 + s2 +-- > where +-- > s1 = cmealy clk100 mac 0 (bundle clk100 (a,x)) +-- > s2 = cmealy clk100 mac 0 (bundle clk100 (b,y)) +cmealy :: SClock clk -- ^ 'Clock' to synchronize to + -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (CSignal clk i -> CSignal clk o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +cmealy clk f iS = \i -> let (s',o) = unbundle clk $ f <$> s <*> i + s = cregister clk iS s' + in o + +{-# INLINE cmealyB #-} +-- | A version of 'cmealy' that does automatic 'Bundle'ing +-- +-- Given a function @f@ of type: +-- +-- > f :: Int -> (Bool,Int) -> (Int,(Int,Bool)) +-- +-- When we want to make compositions of @f@ in @g@ using 'cmealy', we have to +-- write: +-- +-- @ +-- g clk a b c = (b1,b2,i2) +-- where +-- (i1,b1) = 'unbundle' clk (cmealy clk f 0 ('bundle' clk (a,b))) +-- (i2,b2) = 'unbundle' clk (cmealy clk f 3 ('bundle' clk (i1,c))) +-- @ +-- +-- Using 'cmealyB' however we can write: +-- +-- > g a b c = (b1,b2,i2) +-- > where +-- > (i1,b1) = cmealyB clk f 0 (a,b) +-- > (i2,b2) = cmealyB clk f 3 (i1,c) +cmealyB :: (Bundle i, Bundle o) + => SClock clk + -> (s -> i -> (s,o)) -- ^ Transfer function in mealy machine form: + -- @state -> input -> (newstate,output)@ + -> s -- ^ Initial state + -> (Unbundled clk i -> Unbundled clk o) + -- ^ Synchronous sequential function with input and output matching that + -- of the mealy machine +cmealyB clk f iS i = unbundle clk (cmealy clk f iS (bundle clk i)) diff --git a/src/CLaSH/Prelude/Testbench.hs b/src/CLaSH/Prelude/Testbench.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Prelude/Testbench.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module CLaSH.Prelude.Testbench + ( -- * Testbench functions for circuits synchronised to the system slock + sassert + , stimuliGenerator + , outputVerifier + -- * Testbench functions for circuits synchronised to arbitrary clocks + , csassert + , cstimuliGenerator + , coutputVerifier + ) +where + +import Control.Applicative ((<$>), liftA3) +import Debug.Trace (trace) +import GHC.TypeLits (KnownNat) +import Prelude hiding ((!!)) + +import CLaSH.Signal (Signal) +import CLaSH.Signal.Explicit (CSignal, SClock, cregister, systemClock) +import CLaSH.Signal.Bundle (unbundle) +import CLaSH.Sized.Index (Index) +import CLaSH.Sized.Vector (Vec, (!!), maxIndex) + +{-# INLINE sassert #-} +-- | Compares the first two arguments for equality and logs a warning when they +-- are not equal. The second argument is considered the expected value. This +-- function simply returns the third argument unaltered as its result. This +-- function is used by 'outputVerifier'. +-- +-- This function is translated to the following VHDL: +-- +-- > sassert_block : block +-- > begin +-- > -- pragma translate_off +-- > process(clk_1000,reset_1000,arg0,arg1) is +-- > begin +-- > if (rising_edge(clk_1000) or rising_edge(reset_1000)) then +-- > assert (arg0 = arg1) report ("expected: " & to_string (arg1) & \", actual: \" & to_string (arg0)) severity error; +-- > end if; +-- > end process; +-- > -- pragma translate_on +-- > result <= arg2; +-- > end block; +-- +-- And can, due to the pragmas, be used in synthesizable designs +sassert :: (Eq a, Show a) + => Signal a -- ^ Checked value + -> Signal a -- ^ Expected value + -> Signal b -- ^ Returned value + -> Signal b +sassert = csassert + +{-# INLINE stimuliGenerator #-} +-- | To be used as a one of the functions to create the \"magical\" 'testInput' +-- value, which the CλaSH compilers looks for to create the stimulus generator +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- > testInput :: Signal Int +-- > testInput = stimuliGenerator $(v [(1::Int),3..21]) +-- +-- >>> sample testInput +-- [1,3,5,7,9,11,13,15,17,19,21,21,21,... +stimuliGenerator :: forall l a . KnownNat l + => Vec l a -- ^ Samples to generate + -> Signal a -- ^ Signal of given samples +stimuliGenerator = cstimuliGenerator systemClock + +{-# INLINE outputVerifier #-} +-- | To be used as a functions to generate the \"magical\" 'expectedOutput' +-- function, which the CλaSH compilers looks for to create the signal verifier +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- > expectedOutput :: Signal Int -> Signal Bool +-- > expectedOutput = outputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- +-- >>> sample (expectedOutput (fromList ([0..10] ++ [10,10,10]))) +-- [ +-- expected value: 70, not equal to actual value: 0 +-- False, +-- expected value: 99, not equal to actual value: 1 +-- False,False,False,False,False, +-- expected value: 7, not equal to actual value: 6 +-- False, +-- expected value: 8, not equal to actual value: 7 +-- False, +-- expected value: 9, not equal to actual value: 8 +-- False, +-- expected value: 10, not equal to actual value: 9 +-- False,True,True,... +outputVerifier :: forall l a . (KnownNat l, Eq a, Show a) + => Vec l a -- ^ Samples to compare with + -> Signal a -- ^ Signal to verify + -> Signal Bool -- ^ Indicator that all samples are verified +outputVerifier = coutputVerifier systemClock + +{-# NOINLINE csassert #-} +-- | Compares the first two arguments for equality and logs a warning when they +-- are not equal. The second argument is considered the expected value. This +-- function simply returns the third argument unaltered as its result. This +-- function is used by 'coutputVerifier'. +-- +-- +-- This function is translated to the following VHDL: +-- +-- > csassert_block : block +-- > begin +-- > -- pragma translate_off +-- > process(clk_t,reset_t,arg0,arg1) is +-- > begin +-- > if (rising_edge(clk_t) or rising_edge(reset_t)) then +-- > assert (arg0 = arg1) report ("expected: " & to_string (arg1) & \", actual: \" & to_string (arg0)) severity error; +-- > end if; +-- > end process; +-- > -- pragma translate_on +-- > result <= arg2; +-- > end block; +-- +-- And can, due to the pragmas, be used in synthesizable designs +csassert :: (Eq a,Show a) + => CSignal t a -- ^ Checked value + -> CSignal t a -- ^ Expected value + -> CSignal t b -- ^ Return valued + -> CSignal t b +csassert = liftA3 + (\a' b' c' -> if a' == b' then c' + else trace (concat [ "\nexpected value: " + , show b' + , ", not equal to actual value: " + , show a' + ]) c') + +{-# INLINABLE cstimuliGenerator #-} +-- | To be used as a one of the functions to create the \"magical\" 'testInput' +-- value, which the CλaSH compilers looks for to create the stimulus generator +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA :: SClock ClkA +-- > clkA = sclock +-- > +-- > testInput :: CSignal clkA Int +-- > testInput = cstimuliGenerator clkA $(v [(1::Int),3..21]) +-- +-- >>> csample testInput +-- [1,3,5,7,9,11,13,15,17,19,21,21,21,... +cstimuliGenerator :: forall l clk a . KnownNat l + => SClock clk -- ^ Clock to which to synchronize the + -- output signal + -> Vec l a -- ^ Samples to generate + -> CSignal clk a -- ^ Signal of given samples +cstimuliGenerator clk samples = + let (r,o) = unbundle clk (genT <$> cregister clk 0 r) + in o + where + genT :: Index l -> (Index l,a) + genT s = (s',samples !! s) + where + maxI = fromInteger (maxIndex samples) + + s' = if s < maxI + then s + 1 + else s + +{-# INLINABLE coutputVerifier #-} +-- | To be used as a functions to generate the \"magical\" 'expectedOutput' +-- function, which the CλaSH compilers looks for to create the signal verifier +-- for the generated VHDL testbench. +-- +-- Example: +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA :: SClock ClkA +-- > clkA = sclock +-- > +-- > expectedOutput :: CSignal ClkA Int -> CSignal ClkA Bool +-- > expectedOutput = coutputVerifier clkA $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- +-- >>> csample (expectedOutput (cfromList ([0..10] ++ [10,10,10]))) +-- [ +-- expected value: 70, not equal to actual value: 0 +-- False, +-- expected value: 99, not equal to actual value: 1 +-- False,False,False,False,False, +-- expected value: 7, not equal to actual value: 6 +-- False, +-- expected value: 8, not equal to actual value: 7 +-- False, +-- expected value: 9, not equal to actual value: 8 +-- False, +-- expected value: 10, not equal to actual value: 9 +-- False,True,True,... +coutputVerifier :: forall l clk a . (KnownNat l, Eq a, Show a) + => SClock clk -- ^ Clock to which the input signal is + -- synchronized to + -> Vec l a -- ^ Samples to compare with + -> CSignal clk a -- ^ Signal to verify + -> CSignal clk Bool -- ^ Indicator that all samples are verified +coutputVerifier clk samples i = + let (s,o) = unbundle clk (genT <$> cregister clk 0 s) + (e,f) = unbundle clk o + in csassert i e (cregister clk False f) + where + genT :: Index l -> (Index l,(a,Bool)) + genT s = (s',(samples !! s,finished)) + where + maxI = fromInteger (maxIndex samples) + + s' = if s < maxI + then s + 1 + else s + + finished = s == maxI diff --git a/src/CLaSH/Promoted/Nat.hs b/src/CLaSH/Promoted/Nat.hs --- a/src/CLaSH/Promoted/Nat.hs +++ b/src/CLaSH/Promoted/Nat.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module CLaSH.Promoted.Nat - ( SNat, snat, withSNat, snatToInteger + ( SNat (..), snat, withSNat, snatToInteger , UNat (..), toUNat, addUNat, multUNat, powUNat ) where @@ -16,29 +16,37 @@ -- | Singleton value for a type-level natural number 'n' -- -- * "CLaSH.Promoted.Nat.Literals" contains a list of predefined 'SNat' literals --- * "CLaSH.Promoted.Nat.TH" has functions to easily create large ranges of new 'SNat' literals +-- * "CLaSH.Promoted.Nat.TH" has functions to easily create large ranges of new +-- 'SNat' literals data SNat (n :: Nat) = KnownNat n => SNat (Proxy n) instance Show (SNat n) where show (SNat p) = 'd' : show (natVal p) +{-# INLINE snat #-} -- | Create a singleton literal for a type-level natural number snat :: KnownNat n => SNat n snat = SNat Proxy +{-# INLINE withSNat #-} -- | Supply a function with a singleton natural 'n' according to the context withSNat :: KnownNat n => (SNat n -> a) -> a withSNat f = f (SNat Proxy) +{-# INLINE snatToInteger #-} snatToInteger :: SNat n -> Integer snatToInteger (SNat p) = natVal p -- | Unary representation of a type-level natural +-- +-- __NB__: Not synthesisable data UNat :: Nat -> * where UZero :: UNat 0 USucc :: UNat n -> UNat (n + 1) --- | Convert a singleton natural number to it's unary representation +-- | Convert a singleton natural number to its unary representation +-- +-- __NB__: Not synthesisable toUNat :: SNat n -> UNat n toUNat (SNat p) = fromI (natVal p) where @@ -47,18 +55,24 @@ fromI n = unsafeCoerce (USucc (fromI (n - 1))) -- | Add two singleton natural numbers +-- +-- __NB__: Not synthesisable addUNat :: UNat n -> UNat m -> UNat (n + m) addUNat UZero y = y addUNat x UZero = x addUNat (USucc x) y = unsafeCoerce (USucc (addUNat x y)) -- | Multiply two singleton natural numbers +-- +-- __NB__: Not synthesisable multUNat :: UNat n -> UNat m -> UNat (n * m) multUNat UZero _ = UZero multUNat _ UZero = UZero multUNat (USucc x) y = unsafeCoerce (addUNat y (multUNat x y)) -- | Exponential of two singleton natural numbers +-- +-- __NB__: Not synthesisable powUNat :: UNat n -> UNat m -> UNat (n ^ m) powUNat _ UZero = USucc UZero powUNat x (USucc y) = unsafeCoerce (multUNat x (powUNat x y)) diff --git a/src/CLaSH/Promoted/Nat/TH.hs b/src/CLaSH/Promoted/Nat/TH.hs --- a/src/CLaSH/Promoted/Nat/TH.hs +++ b/src/CLaSH/Promoted/Nat/TH.hs @@ -7,7 +7,7 @@ -- | Create an 'SNat' literal -- --- > $(decLiteralD "d" 1200) +-- > $(decLiteralD 1200) -- -- >>> :t d1200 -- d1200 :: SNat 1200 diff --git a/src/CLaSH/Promoted/Symbol.hs b/src/CLaSH/Promoted/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Promoted/Symbol.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +module CLaSH.Promoted.Symbol where + +import Data.Proxy (Proxy (..)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +-- | Singleton value for a type-level string @s@ +data SSymbol (s :: Symbol) = KnownSymbol s => SSymbol (Proxy s) + +instance Show (SSymbol s) where + show (SSymbol s) = symbolVal s + +{-# INLINE ssymbol #-} +-- | Create a singleton literal for a type-level natural number +ssymbol :: KnownSymbol s => SSymbol s +ssymbol = SSymbol Proxy + +{-# INLINE ssymbolToString #-} +ssymbolToString :: SSymbol s -> String +ssymbolToString (SSymbol s) = symbolVal s diff --git a/src/CLaSH/Signal.hs b/src/CLaSH/Signal.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Signal.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE MagicHash #-} + +module CLaSH.Signal + ( -- * Implicitly clocked synchronous signal + Signal + -- * Basic circuit functions + , signal + , register + , regEn + , mux + -- * Boolean connectives + , (.&&.), (.||.), not1 + -- * Product/Signal isomorphism + , Bundle + , Unbundled' + , bundle' + , unbundle' + -- * Simulation functions (not synthesisable) + , simulate + , simulateB + -- * List \<-\> Signal conversion (not synthesisable) + , sample + , sampleN + , fromList + -- * Type classes + -- ** 'Eq'-like + , (.==.), (./=.) + -- ** 'Ord'-like + , compare1, (.<.), (.<=.), (.>=.), (.>.) + -- ** 'Enum'-like + , fromEnum1 + -- ** 'Rational'-like + , toRational1 + -- ** 'Integral'-like + , toInteger1 + -- ** 'Bits'-like + , testBit1 + , popCount1 + , shift1 + , rotate1 + , setBit1 + , clearBit1 + , shiftL1 + , unsafeShiftL1 + , shiftR1 + , unsafeShiftR1 + , rotateL1 + , rotateR1 + ) +where + +import CLaSH.Signal.Internal (CSignal, register#, regEn#, signal#, (.==.), (./=.), + compare1, (.<.), (.<=.), (.>=.), (.>.), fromEnum1, + toRational1, toInteger1, testBit1, popCount1, + shift1, rotate1, setBit1, clearBit1, shiftL1, + unsafeShiftL1, shiftR1, unsafeShiftR1, rotateL1, + rotateR1, (.||.), (.&&.), not1, mux) +import CLaSH.Signal.Explicit (SystemClock, cfromList, csample, csampleN, + systemClock) +import CLaSH.Signal.Bundle (Bundle (..), Unbundled) + +-- * Implicitly clocked synchronous signal + +-- | Signal synchronised to the \"system\" clock, which has a period of 1000. +type Signal a = CSignal SystemClock a + +-- * Basic circuit functions + +{-# INLINE signal #-} +-- | Create a constant 'Signal' from a combinational value +-- +-- >>> sample (signal 4) +-- [4, 4, 4, 4, ... +signal :: a -> Signal a +signal = signal# + +{-# INLINE register #-} +-- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets +-- the value at time 0 to @i@ +-- +-- >>> sampleN 3 (register 8 (fromList [1,2,3,4])) +-- [8,1,2] +register :: a -> Signal a -> Signal a +register = register# systemClock + +{-# INLINE regEn #-} +-- | Version of 'register' that only updates its content when its second argument +-- is asserted. So given: +-- +-- @ +-- oscillate = register False ('not1' oscillate) +-- count = regEn 0 oscillate (count + 1) +-- @ +-- +-- We get: +-- +-- >>> sampleN 8 oscillate +-- [False,True,False,True,False,True,False,True] +-- >>> sampleN 8 count +-- [0,0,1,1,2,2,3,3] +regEn :: a -> Signal Bool -> Signal a -> Signal a +regEn = regEn# systemClock + +-- * Product/Signal isomorphism + +-- | Isomorphism between a 'Signal' of a product type (e.g. a tuple) and a +-- product type of 'Signal's. +type Unbundled' a = Unbundled SystemClock a + +{-# INLINE unbundle' #-} +-- | Example: +-- +-- > unbundle' :: Signal (a,b) -> (Signal a, Signal b) +-- +-- However: +-- +-- > unbundle' :: Signal Bit -> Signal Bit +unbundle' :: Bundle a => Signal a -> Unbundled' a +unbundle' = unbundle systemClock + +{-# INLINE bundle' #-} +-- | Example: +-- +-- > bundle' :: (Signal a, Signal b) -> Signal (a,b) +-- +-- However: +-- +-- > bundle' :: Signal Bit -> Signal Bit +bundle' :: Bundle a => Unbundled' a -> Signal a +bundle' = bundle systemClock + +-- * Simulation functions (not synthesisable) + +-- | Simulate a (@'Signal' a -> 'Signal' b@) function given a list of samples of +-- type @a@ +-- +-- >>> simulate (register 8) [1, 2, 3, ... +-- [8, 1, 2, 3, ... +-- +-- __NB__: This function is not synthesisable +simulate :: (Signal a -> Signal b) -> [a] -> [b] +simulate f = sample . f . fromList + +-- | Simulate a (@'Bundled' a -> 'Bundled' b@) function given a list of samples +-- of type @a@ +-- +-- >>> simulateB (wrap . register (8,8) . unwrap) [(1,1), (2,2), (3,3), ... +-- [(8,8), (1,1), (2,2), (3,3), ... +-- +-- __NB__: This function is not synthesisable +simulateB :: (Bundle a, Bundle b) => (Unbundled' a -> Unbundled' b) -> [a] -> [b] +simulateB f = simulate (bundle' . f . unbundle') + +-- * List \<-\> Signal conversion (not synthesisable) + +-- | Get an infinite list of samples from a 'Signal' +-- +-- The elements in the list correspond to the values of the 'Signal' at +-- consecutive clock cycles +-- +-- > sample s == [s0, s1, s2, s3, ... +-- +-- __NB__: This function is not synthesisable +sample :: Signal a -> [a] +sample = csample + +-- | Get a list of @n@ samples from a 'Signal' +-- +-- The elements in the list correspond to the values of the 'Signal' at +-- consecutive clock cycles +-- +-- > sampleN 3 s == [s0, s1, s2] +-- +-- __NB__: This function is not synthesisable +sampleN :: Int -> Signal a -> [a] +sampleN = csampleN + +-- | Create a 'Signal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> sampleN 2 (fromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +fromList :: [a] -> Signal a +fromList = cfromList diff --git a/src/CLaSH/Signal/Bundle.hs b/src/CLaSH/Signal/Bundle.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Signal/Bundle.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The Product/Signal isomorphism +module CLaSH.Signal.Bundle + ( Bundle (..) + ) +where + +import Control.Applicative ((<$>), (<*>), liftA2) +import Data.Traversable (sequenceA) +import GHC.TypeLits (KnownNat) +import Prelude hiding (head, map, tail) + +import CLaSH.Signal.Internal (Clock, CSignal (..), SClock) +import CLaSH.Sized.BitVector (BitVector) +import CLaSH.Sized.Fixed (Fixed) +import CLaSH.Sized.Index (Index) +import CLaSH.Sized.Signed (Signed) +import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.Sized.Vector (Vec) + +-- | Isomorphism between a 'CSignal' of a product type (e.g. a tuple) and a +-- product type of 'CSignal's. +-- +-- Instances of 'Bundle' must satisfy the following laws: +-- +-- @ +-- bundle . unbundle = 'id' +-- unbundle . bundle = 'id' +-- @ +class Bundle a where + type Unbundled (clk :: Clock) a + type Unbundled clk a = CSignal clk a + -- | Example: + -- + -- > bundle :: (CSignal clk a, CSignal clk b) -> CSignal clk (a,b) + -- + -- However: + -- + -- > bundle :: CSignal clk Bit -> CSignal clk Bit + bundle :: SClock clk -> Unbundled clk a -> CSignal clk a + + {-# INLINE bundle #-} + default bundle :: SClock clk -> CSignal clk a -> CSignal clk a + bundle _ s = s + -- | Example: + -- + -- > unbundle :: CSignal clk (a,b) -> (CSignal clk a, CSignal clk b) + -- + -- However: + -- + -- > unbundle :: CSignal clk Bit -> CSignal clk Bit + unbundle :: SClock clk -> CSignal clk a -> Unbundled clk a + + {-# INLINE unbundle #-} + default unbundle :: SClock clk -> CSignal clk a -> CSignal clk a + unbundle _ s = s + +instance Bundle Bool +instance Bundle Integer +instance Bundle Int +instance Bundle Float +instance Bundle Double +instance Bundle () +instance Bundle (Maybe a) +instance Bundle (Either a b) + +instance Bundle (BitVector n) +instance Bundle (Index n) +instance Bundle (Fixed rep int frac) +instance Bundle (Signed n) +instance Bundle (Unsigned n) + +instance Bundle (a,b) where + type Unbundled t (a,b) = (CSignal t a, CSignal t b) + bundle _ = uncurry (liftA2 (,)) + unbundle _ tup = (fmap fst tup, fmap snd tup) + +instance Bundle (a,b,c) where + type Unbundled t (a,b,c) = (CSignal t a, CSignal t b, CSignal t c) + bundle _ (a,b,c) = (,,) <$> a <*> b <*> c + unbundle _ tup = (fmap (\(x,_,_) -> x) tup + ,fmap (\(_,x,_) -> x) tup + ,fmap (\(_,_,x) -> x) tup + ) + +instance Bundle (a,b,c,d) where + type Unbundled t (a,b,c,d) = ( CSignal t a, CSignal t b, CSignal t c + , CSignal t d + ) + bundle _ (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d + unbundle _ tup = (fmap (\(x,_,_,_) -> x) tup + ,fmap (\(_,x,_,_) -> x) tup + ,fmap (\(_,_,x,_) -> x) tup + ,fmap (\(_,_,_,x) -> x) tup + ) + +instance Bundle (a,b,c,d,e) where + type Unbundled t (a,b,c,d,e) = ( CSignal t a, CSignal t b, CSignal t c + , CSignal t d, CSignal t e + ) + bundle _ (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e + unbundle _ tup = (fmap (\(x,_,_,_,_) -> x) tup + ,fmap (\(_,x,_,_,_) -> x) tup + ,fmap (\(_,_,x,_,_) -> x) tup + ,fmap (\(_,_,_,x,_) -> x) tup + ,fmap (\(_,_,_,_,x) -> x) tup + ) + +instance Bundle (a,b,c,d,e,f) where + type Unbundled t (a,b,c,d,e,f) = ( CSignal t a, CSignal t b, CSignal t c + , CSignal t d, CSignal t e, CSignal t f + ) + bundle _ (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f + unbundle _ tup = (fmap (\(x,_,_,_,_,_) -> x) tup + ,fmap (\(_,x,_,_,_,_) -> x) tup + ,fmap (\(_,_,x,_,_,_) -> x) tup + ,fmap (\(_,_,_,x,_,_) -> x) tup + ,fmap (\(_,_,_,_,x,_) -> x) tup + ,fmap (\(_,_,_,_,_,x) -> x) tup + ) + +instance Bundle (a,b,c,d,e,f,g) where + type Unbundled t (a,b,c,d,e,f,g) = ( CSignal t a, CSignal t b, CSignal t c + , CSignal t d, CSignal t e, CSignal t f + , CSignal t g + ) + bundle _ (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f + <*> g + unbundle _ tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup + ,fmap (\(_,x,_,_,_,_,_) -> x) tup + ,fmap (\(_,_,x,_,_,_,_) -> x) tup + ,fmap (\(_,_,_,x,_,_,_) -> x) tup + ,fmap (\(_,_,_,_,x,_,_) -> x) tup + ,fmap (\(_,_,_,_,_,x,_) -> x) tup + ,fmap (\(_,_,_,_,_,_,x) -> x) tup + ) + +instance Bundle (a,b,c,d,e,f,g,h) where + type Unbundled t (a,b,c,d,e,f,g,h) = ( CSignal t a, CSignal t b, CSignal t c + , CSignal t d, CSignal t e, CSignal t f + , CSignal t g, CSignal t h + ) + bundle _ (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f + <*> g <*> h + unbundle _ tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup + ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup + ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup + ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup + ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup + ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup + ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup + ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup + ) + +instance KnownNat n => Bundle (Vec n a) where + type Unbundled t (Vec n a) = Vec n (CSignal t a) + -- The 'Traversable' instance of 'Vec' is not synthesisable, so we must + -- define 'bundle' as a primitive. + bundle = vecBundle# + unbundle _ = sequenceA + +{-# NOINLINE vecBundle# #-} +vecBundle# :: SClock t -> Vec n (CSignal t a) -> CSignal t (Vec n a) +vecBundle# _ = sequenceA diff --git a/src/CLaSH/Signal/Delayed.hs b/src/CLaSH/Signal/Delayed.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Signal/Delayed.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module CLaSH.Signal.Delayed + ( -- * Delay-annotated synchronous signals + DSignal + , dsignal + , delay + , delayI + , feedback + -- * Signal \<-\> DSignal conversion + , fromSignal + , toSignal + , unsafeFromSignal + -- * List \<-\> DSignal conversion (not synthesisable) + , dsample + , dsampleN + , dfromList + ) +where + +import Data.Coerce (coerce) +import Data.Default (Default(..)) +import Control.Applicative (Applicative (..)) +import GHC.TypeLits (KnownNat, Nat, type (-)) +import Language.Haskell.TH.Syntax (Lift) +import Prelude hiding (head, length, repeat) + +import CLaSH.Sized.Vector (Vec, head, length, repeat, shiftInAt0, + singleton) + +import CLaSH.Signal (Signal, fromList, register, sample, sampleN, + bundle', unbundle') + +-- | A synchronized signal with samples of type @a@, synchronized to \"system\" +-- clock (period 1000), that has accumulated @delay@ amount of samples delay +-- along its path. +newtype DSignal (delay :: Nat) a = + DSignal { -- | Strip a 'DSignal' from its delay information. + toSignal :: Signal a + } + deriving (Show,Default,Lift,Functor,Applicative,Num) + +-- | Create a 'DSignal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> dsampleN 2 (fromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +dfromList :: [a] -> DSignal 0 a +dfromList = coerce . fromList + +-- | Get an infinite list of samples from a 'DSignal' +-- +-- The elements in the list correspond to the values of the 'DSignal' at +-- consecutive clock cycles +-- +-- > dsample s == [s0, s1, s2, s3, ... +-- +-- __NB__: This function is not synthesisable +dsample :: DSignal t a -> [a] +dsample = sample . coerce + +-- | Get a list of @n@ samples from a 'DSignal' +-- +-- The elements in the list correspond to the values of the 'DSignal' at +-- consecutive clock cycles +-- +-- > dsampleN 3 s == [s0, s1, s2] +-- +-- __NB__: This function is not synthesisable +dsampleN :: Int -> DSignal t a -> [a] +dsampleN n = sampleN n . coerce + + +-- | Create a constant 'DSignal' from a combinational value +-- +-- >>> dsample (dsignal 4) +-- [4, 4, 4, 4, ... +dsignal :: a -> DSignal n a +dsignal = pure + +-- | Delay a 'DSignal' for @m@ periods. +-- +-- > delay3 :: DSignal (n - 3) Int -> DSignal n Int +-- > delay3 = delay (0 :> 0 :> 0 :> Nil) +-- +-- >>> dsampleN 6 (delay3 (dfromList [1..])) +-- [0,0,0,1,2,3] +delay :: forall a n m . KnownNat m + => Vec m a + -> DSignal (n - m) a + -> DSignal n a +delay m ds = coerce (delay' (coerce ds)) + where + delay' :: Signal a -> Signal a + delay' s = case length m of + 0 -> s + _ -> let (r',o) = shiftInAt0 (unbundle' r) (singleton s) + r = register m (bundle' r') + in head o + +-- | Delay a 'DSignal' for @m@ periods, where @m@ is derived from the context. +-- +-- > delay2 :: DSignal (n - 2) Int -> DSignal n Int +-- > delay2 = delayI +-- +-- >>> dsampleN 6 (delay2 (dfromList [1..]) +-- [0,0,1,2,3,4] +delayI :: (Default a, KnownNat m) + => DSignal (n - m) a + -> DSignal n a +delayI = delay (repeat def) + +-- | Feed the delayed result of a function back to its input: +-- +-- @ +-- mac :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int +-- mac x y = 'feedback' (mac' x y) +-- where +-- mac' :: DSignal 0 Int -> DSignal 0 Int -> DSignal 0 Int +-- -> (DSignal 0 Int, DSignal 1 Int) +-- mac' a b acc = let acc' = a * b + acc +-- in (acc, delay ('singleton' 0) acc') +-- @ +-- +-- >>> dsampleN 6 (mac (dfromList [1..]) (dfromList [1..])) +-- [0,1,5,14,30,55] +feedback :: (DSignal (n - m - 1) a -> (DSignal (n - m - 1) a,DSignal n a)) + -> DSignal (n - m - 1) a +feedback f = let (o,r) = f (coerce r) in o + +-- | 'Signal's are not delayed +-- +-- > sample s == dsample (fromSignal s) +fromSignal :: Signal a -> DSignal 0 a +fromSignal = coerce + + +-- | __Unsafely__ convert a 'Signal' to /any/ 'DSignal'. +-- +-- __NB__: Should only be used to interface with functions specified in terms of +-- 'Signal'. +unsafeFromSignal :: Signal a -> DSignal n a +unsafeFromSignal = DSignal diff --git a/src/CLaSH/Signal/Explicit.hs b/src/CLaSH/Signal/Explicit.hs --- a/src/CLaSH/Signal/Explicit.hs +++ b/src/CLaSH/Signal/Explicit.hs @@ -1,270 +1,147 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} module CLaSH.Signal.Explicit ( -- * Explicitly clocked synchronous signal -- $relativeclocks CSignal -- * Clock domain crossing + -- ** Clock , Clock (..) + , SClock (..) + , sclock + , withSClock + , SystemClock + , systemClock + -- ** Synchronisation primitive , veryUnsafeSynchronizer - , fromImplicit - , fromExplicit - -- * Basic circuit functions + -- * Basic circuit functions , csignal , cregister - , CPack (..) - -- * Simulation functions + , cregEn + -- * Product/Signal isomorphism + , Bundle (..) + -- * Simulation functions (not synthesisable) , csimulate - , csimulateP - -- * List \<-\> CSignal conversion + , csimulateB + -- * List \<-\> CSignal conversion (not synthesisable) , csample , csampleN , cfromList ) where -import Data.Coerce (coerce) -import Control.Applicative (Applicative (..), (<$>), liftA2) -import GHC.TypeLits (Nat) - -import CLaSH.Bit (Bit) -import CLaSH.Promoted.Nat (snatToInteger) -import CLaSH.Sized.Fixed (Fixed) -import CLaSH.Sized.Signed (Signed) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec(..), vmap, vhead, vtail) - -import CLaSH.Signal.Implicit -import CLaSH.Signal.Types - -{-# NOINLINE cregister #-} +import qualified Data.Foldable as F +import GHC.TypeLits (KnownNat, KnownSymbol) -{-# NOINLINE veryUnsafeSynchronizer #-} -{-# NOINLINE fromImplicit #-} -{-# NOINLINE fromExplicit #-} +import CLaSH.Promoted.Nat (snat, snatToInteger) +import CLaSH.Promoted.Symbol (ssymbol) +import CLaSH.Signal.Internal (CSignal (..), Clock (..), SClock (..), signal#, + register#, regEn#) +import CLaSH.Signal.Bundle (Bundle (..), Unbundled) {- $relativeclocks #relativeclocks# -CλaSH supports explicitly clocked 'Signal's in the form of: \"@'CSignal' clk a@\", -where @clk@ is a 'Nat'ural number corresponding to the clock period of the clock -the signal is synchronized to. NB: \"Bad things\"™ happen when you actually use -a clock period of @0@, so don't do that! - -The clock periods are however dimension-less, they do not refer to any explicit -time-scale (e.g. nano-seconds). The reason for the lack of an explicit time-scale -is that the CλaSH compiler would not be able guarantee that the circuit can run -at the specified frequency. - -The clock periods are just there to indicate relative frequency differences -between two different clocks. That is, a \"@'CSignal' 500 a@\" is synchronized -to a clock that runs 6.5 times faster than the clock to which a -\"@'CSignal' 3250 a@\" is synchronized to. NB: You should be judicious using a -clock with period @1@ as you can never create a clock that runs faster later on! --} +CλaSH supports explicitly clocked 'CLaSH.Signal's in the form of: --- | Create a 'CSignal' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- NB: Simulation only! --- --- >>> csampleN 2 (cfromList [1,2,3,4,5]) --- [1,2] -cfromList :: [a] -> CSignal t a -cfromList = coerce . fromList +@ +'CSignal' (clk :: 'Clock') a +@ --- | Get an infinite list of samples from a 'CSignal' --- --- The elements in the list correspond to the values of the 'CSignal' at --- consecutive clock cycles --- --- > csample s == [s0, s1, s2, s3, ... -csample :: CSignal t a -> [a] -csample = sample . coerce +Where @a@ is the type of the elements, and @clk@ is the clock to which the +signal is synchronised. The type-parameter, @clk@, is of the kind 'Clock' which +has types of the following shape: --- | Get a list of @n@ samples from a 'CSignal' --- --- The elements in the list correspond to the values of the 'CSignal' at --- consecutive clock cycles --- --- > csampleN 3 s == [s0, s1, s2] -csampleN :: Int -> CSignal t a -> [a] -csampleN n = sampleN n . coerce +@ +Clk \{\- name :: \-\} 'GHC.TypeLits.Symbol' \{\- period :: \-\} 'GHC.TypeLits.Nat' +@ --- | 'cregister' @i s@ delays the values in 'CSignal' @s@ for one cycle, and sets --- the value at time 0 to @i@ --- --- > clk100 = Clock d100 --- --- >>> csampleN 3 (cregister d100 8 (fromList [1,2,3,4])) --- [8,1,2] -cregister :: Clock clk -> a -> CSignal clk a -> CSignal clk a -cregister _ i s = coerce (register i (coerce s)) +Where @name@ is a type-level string ('GHC.TypeLits.Symbol') representing the the +name of the clock, and @period@ is a type-level natural number ('GHC.TypeLits.Nat') +representing the clock period. Two concrete instances of a 'Clk' could be: --- | Simulate a (@'CSignal' clk1 a -> 'Signal' clk2 b@) function given a list of --- samples of type @a@ --- --- >>> simulate (register 8) [1, 2, 3, ... --- [8, 1, 2, 3, ... -csimulate :: (CSignal clk1 a -> CSignal clk2 b) -> [a] -> [b] -csimulate f = csample . f . cfromList +> type ClkA500 = Clk "A500" 500 +> type ClkB3250 = Clk "B3250" 3250 --- | Isomorphism between a @'CSignal' clk@ of a product type (e.g. a tuple) and a --- product type of @'CSignal' clk@'s --- --- Instances of 'CPack' must satisfy the following laws: --- --- @ --- cpack clk . cunpack clk = 'id' --- cunpack clk . cpack clk = 'id' --- @ -class CPack a where - type CSignalP (clk :: Nat) a - type CSignalP clk a = CSignal clk a - -- | Example: - -- - -- > cpack :: Clock clk -> (CSignal clk a, CSignal clk b) -> CSignal clk (a,b) - -- - -- However: - -- - -- > cpack :: Clock clk -> CSignal clk Bit -> CSignal clk Bit - cpack :: Clock clk -> CSignalP clk a -> CSignal clk a +The periods of these clocks are however dimension-less, they do not refer to any +explicit time-scale (e.g. nano-seconds). The reason for the lack of an explicit +time-scale is that the CλaSH compiler would not be able guarantee that the +circuit can run at the specified frequency. The clock periods are just there to +indicate relative frequency differences between two different clocks. That is, a +signal: - default cpack :: Clock clk -> CSignal clk a -> CSignal clk a - cpack _ s = s - -- | Example: - -- - -- > cunpack :: Clock clk -> CSignal clk (a,b) -> (CSignal clk a, CSignal clk b) - -- - -- However: - -- - -- > cunpack :: Clock clk -> CSignal clk Bit -> CSignal clk Bit - cunpack :: Clock clk -> CSignal clk a -> CSignalP clk a +@ +'CSignal' ClkA500 a +@ - default cunpack :: Clock clk -> CSignal clk a -> CSignal clk a - cunpack _ s = s +is synchronized to a clock that runs 6.5 times faster than the clock to which +the signal: -instance CPack Bit -instance CPack (Signed n) -instance CPack (Unsigned n) -instance CPack (Fixed frac rep size) -instance CPack Bool -instance CPack Integer -instance CPack Int -instance CPack Float -instance CPack Double -instance CPack () -instance CPack (Maybe a) -instance CPack (Either a b) +@ +'CSignal' ClkB3250 a +@ -instance CPack (a,b) where - type CSignalP t (a,b) = (CSignal t a, CSignal t b) - cpack _ = uncurry (liftA2 (,)) - cunpack _ tup = (fmap fst tup, fmap snd tup) +is synchronized to. -instance CPack (a,b,c) where - type CSignalP t (a,b,c) = (CSignal t a, CSignal t b, CSignal t c) - cpack _ (a,b,c) = (,,) <$> a <*> b <*> c - cunpack _ tup = (fmap (\(x,_,_) -> x) tup - ,fmap (\(_,x,_) -> x) tup - ,fmap (\(_,_,x) -> x) tup - ) +* __NB__: \"Bad things\"™ happen when you actually use a clock period of @0@, +so do __not__ do that! +* __NB__: You should be judicious using a clock with period of @1@ as you can +never create a clock that faster! +-} -instance CPack (a,b,c,d) where - type CSignalP t (a,b,c,d) = (CSignal t a, CSignal t b, CSignal t c, CSignal t d) - cpack _ (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d - cunpack _ tup = (fmap (\(x,_,_,_) -> x) tup - ,fmap (\(_,x,_,_) -> x) tup - ,fmap (\(_,_,x,_) -> x) tup - ,fmap (\(_,_,_,x) -> x) tup - ) +-- * Clock domain crossing -instance CPack (a,b,c,d,e) where - type CSignalP t (a,b,c,d,e) = (CSignal t a, CSignal t b, CSignal t c, CSignal t d, CSignal t e) - cpack _ (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e - cunpack _ tup = (fmap (\(x,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,x) -> x) tup - ) +-- ** Clock -instance CPack (a,b,c,d,e,f) where - type CSignalP t (a,b,c,d,e,f) = (CSignal t a, CSignal t b, CSignal t c, CSignal t d, CSignal t e, CSignal t f) - cpack _ (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f - cunpack _ tup = (fmap (\(x,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,x) -> x) tup - ) +{-# INLINE sclock #-} +-- | Create a singleton clock +sclock :: (KnownSymbol name, KnownNat period) + => SClock (Clk name period) +sclock = SClock ssymbol snat -instance CPack (a,b,c,d,e,f,g) where - type CSignalP t (a,b,c,d,e,f,g) = (CSignal t a, CSignal t b, CSignal t c, CSignal t d, CSignal t e, CSignal t f, CSignal t g) - cpack _ (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f <*> g - cunpack _ tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x) -> x) tup - ) +{-# INLINE withSClock #-} +withSClock :: (KnownSymbol name, KnownNat period) + => (SClock (Clk name period) -> a) + -> a +withSClock f = f (SClock ssymbol snat) -instance CPack (a,b,c,d,e,f,g,h) where - type CSignalP t (a,b,c,d,e,f,g,h) = (CSignal t a, CSignal t b, CSignal t c, CSignal t d, CSignal t e, CSignal t f, CSignal t g, CSignal t h) - cpack _ (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h - cunpack _ tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup - ) +-- | The standard system clock with a period of 1000 +type SystemClock = Clk "system" 1000 -instance CPack (Vec n a) where - type CSignalP t (Vec n a) = Vec n (CSignal t a) - cpack clk vs = mkCSignal (vmap (shead . coerce) vs) (cpack clk (vmap cstail vs)) - cunpack _ (CSignal (Nil :- _)) = Nil - cunpack clk vs@(CSignal ((_ :> _) :- _)) = fmap vhead vs :> cunpack clk (fmap vtail vs) +{-# INLINE systemClock #-} +-- | The singleton clock for 'SystemClock' +systemClock :: SClock SystemClock +systemClock = sclock --- | Simulate a (@'CSignalP' clk1 a -> 'CSignalP' clk2 b@) function given a list --- of samples of type @a@ +-- ** Synchronisation primitive +{-# NOINLINE veryUnsafeSynchronizer #-} +-- | The 'veryUnsafeSynchronizer' function is a primitive that must be used to +-- connect one clock domain to the other, and will be synthesised to a (bundle +-- of) wire(s) in the eventual circuit. This function should only be used as +-- part of a proper synchronisation component, such as the following dual +-- flip-flop synchronizer: -- --- > clk100 = Clock d100 +-- > dualFlipFlop :: SClock clkA -> SClock clkB +-- > -> CSignal clkA Bit -> CSignal clkB Bit +-- > dualFlipFlop clkA clkB = cregister clkB low . cregister clkB low +-- > . veryUnsafeSynchronizer clkA clkB -- --- >>> csimulateP clk100 clk100 (cunpack clk100 . cregister clk100 (8,8) . cpack clk100) [(1,1), (2,2), (3,3), ... --- [(8,8), (1,1), (2,2), (3,3), ... -csimulateP :: (CPack a, CPack b) - => Clock clk1 -- ^ 'Clock' of the incoming signal - -> Clock clk2 -- ^ 'Clock' of the outgoing signal - -> (CSignalP clk1 a -> CSignalP clk2 b) -- ^ Function to simulate - -> [a] -> [b] -csimulateP clk1 clk2 f = csimulate (cpack clk2 . f . cunpack clk1) - --- | Synchronisation function that is basically a represented by a (bundle of) --- wire(s) in hardware. This function should only be used as part of a proper --- synchronisation component, such as a dual flip-flop synchronizer, or a FIFO --- with an asynchronous memory element: +-- The 'veryUnsafeSynchronizer' works in such a way that, given 2 clocks: -- --- > dualFlipFlop :: Clock clk1 -> Clock clk2 --- > -> CSignal clk1 Bit -> CSignal clk2 Bit --- > dualFlipFlop clk1 clk2 = cregister clk2 L . cregister clk2 L . veryUnsafeSynchronizer clk1 clk2 +-- > type Clk7 = Clk "clk7" 7 +-- > +-- > clk7 :: SClock Clk7 +-- > clk7 = sclock -- --- The 'veryUnsafeSynchronizer' works in such a way that, given 2 clocks: +-- and -- --- > clk7 = Clock d7 --- > clk2 = Clock d2 +-- > type Clk2 = Clk "clk2" 2 +-- > +-- > clk2 :: SClock Clk2 +-- > clk2 = sclock -- --- Oversampling followed by compression is the identity function plus 2 initial values: +-- Oversampling followed by compression is the identity function plus 2 initial +-- values: -- -- > cregister clk7 i $ -- > veryUnsafeSynchronizer clk2 clk7 $ @@ -278,34 +155,35 @@ -- -- Something we can easily observe: -- --- > oversampling = cregister clk2 99 . veryUnsafeSynchronizer clk7 clk2 . cregister clk7 50 +-- > oversampling = cregister clk2 99 . veryUnsafeSynchronizer clk7 clk2 +-- > . cregister clk7 50 -- > almostId = cregister clk7 70 . veryUnsafeSynchronizer clk2 clk7 --- > . cregister clk2 99 . veryUnsafeSynchronizer clk7 clk2 . cregister clk7 50 --- > +-- > . cregister clk2 99 . veryUnsafeSynchronizer clk7 clk2 +-- > . cregister clk7 50 -- -- >>> csample (oversampling (cfromList [1..10])) -- [99, 50,1,1,1,2,2,2,2, 3,3,3,4,4,4,4, 5,5,5,6,6,6,6, 7,7,7,8,8,8,8, 9,9,9,10,10,10,10, ... -- >>> csample (almostId (cfromList [1..10])) -- [70, 99,1,2,3,4,5,6,7,8,9,10,... -veryUnsafeSynchronizer :: Clock clk1 -- ^ 'Clock' of the incoming signal - -> Clock clk2 -- ^ 'Clock' of the outgoing signal +veryUnsafeSynchronizer :: SClock clk1 -- ^ 'Clock' of the incoming signal + -> SClock clk2 -- ^ 'Clock' of the outgoing signal -> CSignal clk1 a -> CSignal clk2 a -veryUnsafeSynchronizer (Clock clk1) (Clock clk2) s = s' +veryUnsafeSynchronizer (SClock _ period1) (SClock _ period2) s = s' where - t1 = fromInteger (snatToInteger clk1) - t2 = fromInteger (snatToInteger clk2) + t1 = fromInteger (snatToInteger period1) + t2 = fromInteger (snatToInteger period2) s' | t1 < t2 = compress t2 t1 s | t1 > t2 = oversample t1 t2 s | otherwise = same s same :: CSignal clk1 a -> CSignal clk2 a -same (CSignal s) = CSignal s +same (s :- ss) = s :- same ss oversample :: Int -> Int -> CSignal clk1 a -> CSignal clk2 a -oversample high low (CSignal (s :- ss)) = CSignal (s :- oversampleS (reverse (repSchedule high low)) ss) +oversample high low (s :- ss) = s :- oversampleS (reverse (repSchedule high low)) ss -oversampleS :: [Int] -> Signal a -> Signal a +oversampleS :: [Int] -> CSignal clk1 a -> CSignal clk2 a oversampleS sched = oversample' sched where oversample' [] s = oversampleS sched s @@ -315,9 +193,9 @@ prefixN n x s = x :- prefixN (n-1) x s compress :: Int -> Int -> CSignal clk1 a -> CSignal clk2 a -compress high low (CSignal s) = CSignal (compressS (repSchedule high low) s) +compress high low s = compressS (repSchedule high low) s -compressS :: [Int] -> Signal a -> Signal a +compressS :: [Int] -> CSignal clk1 a -> CSignal clk2 a compressS sched = compress' sched where compress' [] s = compressS sched s @@ -333,10 +211,120 @@ | cnt < th = repSchedule' (cnt+low) th (rep + 1) | otherwise = rep : repSchedule' (cnt + low) (th + high) 1 --- | Implicitly clocked signals have a clock with period 1000 -fromImplicit :: Signal a -> CSignal 1000 a -fromImplicit s = CSignal s +-- * Basic circuit functions --- | Implicitly clocked signals have a clock with period 1000 -fromExplicit :: CSignal 1000 a -> Signal a -fromExplicit (CSignal s) = s +{-# INLINE csignal #-} +-- | Create a constant 'CSignal' from a combinational value +-- +-- >>> csample (csignal 4) +-- [4, 4, 4, 4, ... +csignal :: a -> CSignal clk a +csignal = signal# + +{-# INLINE cregister #-} +-- | \"@'cregister' i s@\" delays the values in 'CSignal' @s@ for one cycle, +-- and sets the value at time 0 to @i@ +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- +-- >>> csampleN 3 (cregister clkA100 8 (fromList [1,2,3,4])) +-- [8,1,2] +cregister :: SClock clk -> a -> CSignal clk a -> CSignal clk a +cregister = register# + +{-# INLINE cregEn #-} +-- | Version of 'cregister' that only updates its content when its second +-- argument is asserted. So given: +-- +-- @ +-- type ClkA = Clk \"A\" 100 +-- clkA :: SClock Clka +-- clkA = sclock +-- +-- oscillate = cregister clkA False ('not1' oscillate) +-- count = cregEn clkA 0 oscillate (count + 1) +-- @ +-- +-- We get: +-- +-- >>> csampleN 8 oscillate +-- [False,True,False,True,False,True,False,True] +-- >>> csampleN 8 count +-- [0,0,1,1,2,2,3,3] +cregEn :: SClock clk -> a -> CSignal clk Bool -> CSignal clk a -> CSignal clk a +cregEn = regEn# + +-- * Simulation functions + +-- | Simulate a (@'CSignal' clk1 a -> 'CSignal' clk2 b@) function given a list +-- of samples of type @a@ +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- +-- >>> csimulate (cregister clkA100 8) [1, 2, 3, ... +-- [8, 1, 2, 3, ... +-- +-- __NB__: This function is not synthesisable +csimulate :: (CSignal clk1 a -> CSignal clk2 b) -> [a] -> [b] +csimulate f = csample . f . cfromList + +-- | Simulate a (@'CSignalP' clk1 a -> 'CSignalP' clk2 b@) function given a list +-- of samples of type @a@ +-- +-- > type ClkA = Clk "A" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- +-- >>> csimulateB clkA100 clkA100 (cunpack clkA100 . cregister clkA100 (8,8) . cpack clkA100) [(1,1), (2,2), (3,3), ... +-- [(8,8), (1,1), (2,2), (3,3), ... +-- +-- __NB__: This function is not synthesisable +csimulateB :: (Bundle a, Bundle b) + => SClock clk1 -- ^ 'Clock' of the incoming signal + -> SClock clk2 -- ^ 'Clock' of the outgoing signal + -> (Unbundled clk1 a -> Unbundled clk2 b) -- ^ Function to simulate + -> [a] -> [b] +csimulateB clk1 clk2 f = csimulate (bundle clk2 . f . unbundle clk1) + +-- * List \<-\> CSignal conversion + +-- | Get an infinite list of samples from a 'CSignal' +-- +-- The elements in the list correspond to the values of the 'CSignal' at +-- consecutive clock cycles +-- +-- > csample s == [s0, s1, s2, s3, ... +-- +-- __NB__: This function is not synthesisable +csample :: CSignal clk a -> [a] +csample = F.foldr (:) [] + +-- | Get a list of @n@ samples from a 'CSignal' +-- +-- The elements in the list correspond to the values of the 'CSignal' at +-- consecutive clock cycles +-- +-- > csampleN 3 s == [s0, s1, s2] +-- +-- __NB__: This function is not synthesisable +csampleN :: Int -> CSignal clk a -> [a] +csampleN n = take n . csample + +-- | Create a 'CSignal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> csampleN 2 (cfromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +cfromList :: [a] -> CSignal clk a +cfromList = foldr (:-) (error "finite list") diff --git a/src/CLaSH/Signal/Implicit.hs b/src/CLaSH/Signal/Implicit.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Implicit.hs +++ /dev/null @@ -1,231 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeFamilies #-} - -module CLaSH.Signal.Implicit - ( -- * Implicitly clocked synchronous signal - Signal - -- * Basic circuit functions - , signal - , register - , Pack(..) - , (<^), (^>) - -- * Simulation functions - , simulate - , simulateP - -- * List \<-\> Signal conversion - , sample - , sampleN - , fromList - ) -where - -import Control.Applicative (Applicative (..), (<$>), liftA2) - -import CLaSH.Bit (Bit) -import CLaSH.Sized.Fixed (Fixed) -import CLaSH.Sized.Signed (Signed) -import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec(..), vmap, vhead, vtail) - -import CLaSH.Signal.Types - -{-# NOINLINE register #-} - --- | Create a 'Signal' from a list --- --- Every element in the list will correspond to a value of the signal for one --- clock cycle. --- --- NB: Simulation only! --- --- >>> sampleN 2 (fromList [1,2,3,4,5]) --- [1,2] -fromList :: [a] -> Signal a -fromList [] = error "finite list" -fromList (x:xs) = x :- fromList xs - --- | Get an infinite list of samples from a 'Signal' --- --- The elements in the list correspond to the values of the 'Signal' at --- consecutive clock cycles --- --- > sample s == [s0, s1, s2, s3, ... -sample :: Signal a -> [a] -sample ~(x :- xs) = x : sample xs - --- | Get a list of @n@ samples from a 'Signal' --- --- The elements in the list correspond to the values of the 'Signal' at --- consecutive clock cycles --- --- > sampleN 3 s == [s0, s1, s2] -sampleN :: Int -> Signal a -> [a] -sampleN 0 _ = [] -sampleN n ~(x :- xs) = x : (sampleN (n-1) xs) - --- | 'register' @i s@ delays the values in 'Signal' @s@ for one cycle, and sets --- the value at time 0 to @i@ --- --- >>> sampleN 3 (register 8 (fromList [1,2,3,4])) --- [8,1,2] -register :: a -> Signal a -> Signal a -register i s = i :- s - --- | Simulate a (@'Signal' a -> 'Signal' b@) function given a list of samples of --- type @a@ --- --- >>> simulate (register 8) [1, 2, 3, ... --- [8, 1, 2, 3, ... -simulate :: (Signal a -> Signal b) -> [a] -> [b] -simulate f = sample . f . fromList - --- | Isomorphism between a 'Signal' of a product type (e.g. a tuple) and a --- product type of 'Signal's. --- --- Instances of 'Pack' must satisfy the following laws: --- --- @ --- pack . unpack = 'id' --- unpack . pack = 'id' --- @ -class Pack a where - type SignalP a - type SignalP a = Signal a - -- | Example: - -- - -- > pack :: (Signal a, Signal b) -> Signal (a,b) - -- - -- However: - -- - -- > pack :: Signal Bit -> Signal Bit - pack :: SignalP a -> Signal a - - default pack :: Signal a -> Signal a - pack s = s - -- | Example: - -- - -- > unpack :: Signal (a,b) -> (Signal a, Signal b) - -- - -- However: - -- - -- > unpack :: Signal Bit -> Signal Bit - unpack :: Signal a -> SignalP a - - default unpack :: Signal a -> Signal a - unpack s = s - -instance Pack Bit -instance Pack (Signed n) -instance Pack (Unsigned n) -instance Pack (Fixed frac rep size) -instance Pack Bool -instance Pack Integer -instance Pack Int -instance Pack Float -instance Pack Double -instance Pack () -instance Pack (Maybe a) -instance Pack (Either a b) - -instance Pack (a,b) where - type SignalP (a,b) = (Signal a, Signal b) - pack = uncurry (liftA2 (,)) - unpack tup = (fmap fst tup, fmap snd tup) - -instance Pack (a,b,c) where - type SignalP (a,b,c) = (Signal a, Signal b, Signal c) - pack (a,b,c) = (,,) <$> a <*> b <*> c - unpack tup = (fmap (\(x,_,_) -> x) tup - ,fmap (\(_,x,_) -> x) tup - ,fmap (\(_,_,x) -> x) tup - ) - -instance Pack (a,b,c,d) where - type SignalP (a,b,c,d) = (Signal a, Signal b, Signal c, Signal d) - pack (a,b,c,d) = (,,,) <$> a <*> b <*> c <*> d - unpack tup = (fmap (\(x,_,_,_) -> x) tup - ,fmap (\(_,x,_,_) -> x) tup - ,fmap (\(_,_,x,_) -> x) tup - ,fmap (\(_,_,_,x) -> x) tup - ) - -instance Pack (a,b,c,d,e) where - type SignalP (a,b,c,d,e) = (Signal a, Signal b, Signal c, Signal d, Signal e) - pack (a,b,c,d,e) = (,,,,) <$> a <*> b <*> c <*> d <*> e - unpack tup = (fmap (\(x,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,x) -> x) tup - ) - -instance Pack (a,b,c,d,e,f) where - type SignalP (a,b,c,d,e,f) = (Signal a, Signal b, Signal c, Signal d, Signal e, Signal f) - pack (a,b,c,d,e,f) = (,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f - unpack tup = (fmap (\(x,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,x) -> x) tup - ) - -instance Pack (a,b,c,d,e,f,g) where - type SignalP (a,b,c,d,e,f,g) = (Signal a, Signal b, Signal c, Signal d, Signal e, Signal f, Signal g) - pack (a,b,c,d,e,f,g) = (,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f <*> g - unpack tup = (fmap (\(x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x) -> x) tup - ) - -instance Pack (a,b,c,d,e,f,g,h) where - type SignalP (a,b,c,d,e,f,g,h) = (Signal a, Signal b, Signal c, Signal d, Signal e, Signal f, Signal g, Signal h) - pack (a,b,c,d,e,f,g,h) = (,,,,,,,) <$> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h - unpack tup = (fmap (\(x,_,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,x,_,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,x,_,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,x,_,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,x,_,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,x,_,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,x,_) -> x) tup - ,fmap (\(_,_,_,_,_,_,_,x) -> x) tup - ) - -instance Pack (Vec n a) where - type SignalP (Vec n a) = Vec n (Signal a) - pack vs = vmap shead vs :- pack (vmap stail vs) - unpack (Nil :- _) = Nil - unpack vs@((_ :> _) :- _) = fmap vhead vs :> (unpack (fmap vtail vs)) - --- | Simulate a (@'SignalP' a -> 'SignalP' b@) function given a list of samples --- of type @a@ --- --- >>> simulateP (unpack . register (8,8) . pack) [(1,1), (2,2), (3,3), ... --- [(8,8), (1,1), (2,2), (3,3), ... -simulateP :: (Pack a, Pack b) => (SignalP a -> SignalP b) -> [a] -> [b] -simulateP f = simulate (pack . f . unpack) - --- | Operator lifting, use in conjunction with ('^>') --- --- > add2 :: Signal Int -> Signal Int --- > add2 x = x <^(+)^> (signal 2) --- --- >>> simulate add2 [1,2,3,... --- [3,4,5,... -(<^) :: Applicative f => f a -> (a -> b -> c) -> f b -> f c -v <^ f = liftA2 f v - --- | Operator lifting, use in conjunction with ('<^') --- --- > add2 :: Signal Int -> Signal Int --- > add2 x = x <^(+)^> (signal 2) --- --- >>> simulate add2 [1,2,3,... --- [3,4,5,... -(^>) :: Applicative f => (f a -> f b) -> f a -> f b -f ^> v = f v diff --git a/src/CLaSH/Signal/Internal.hs b/src/CLaSH/Signal/Internal.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Signal/Internal.hs @@ -0,0 +1,361 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module CLaSH.Signal.Internal + ( -- * Datatypes + Clock (..) + , SClock (..) + , CSignal (..) + -- * Basic circuits + , register# + , regEn# + , mux + -- * Boolean connectives + , (.&&.), (.||.), not1 + -- * Type classes + -- ** 'Eq'-like + , (.==.), (./=.) + -- ** 'Ord'-like + , compare1, (.<.), (.<=.), (.>=.), (.>.) + -- ** 'Functor' + , mapSignal# + -- ** 'Applicative' + , signal# + , appSignal# + -- ** 'Foldable' + , foldr# + -- ** 'Traversable' + , traverse# + -- ** 'Enum'-like + , fromEnum1 + -- ** 'Rational'-like + , toRational1 + -- ** 'Integral'-like + , toInteger1 + -- ** 'Bits'-like + , testBit1 + , popCount1 + , shift1 + , rotate1 + , setBit1 + , clearBit1 + , shiftL1 + , unsafeShiftL1 + , shiftR1 + , unsafeShiftR1 + , rotateL1 + , rotateR1 + ) +where + +import Control.Applicative (Applicative (..), (<$>), liftA2, liftA3) +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Default (Default (..)) +import Data.Foldable (Foldable (..)) +import Data.Traversable (Traversable (..)) +import GHC.TypeLits (Nat, Symbol) +import Language.Haskell.TH.Syntax (Lift (..)) + +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..)) +import CLaSH.Promoted.Nat (SNat) +import CLaSH.Promoted.Symbol (SSymbol) + +-- | A clock with a name ('Symbol') and period ('Nat') +data Clock = Clk Symbol Nat + +-- | Singleton value for a type-level 'Clock' with the given @name@ and @period@ +data SClock (clk :: Clock) + where + SClock :: SSymbol name -> SNat period -> SClock (Clk name period) + +infixr 5 :- +-- | A synchronized signal with samples of type @a@, explicitly synchronized to +-- a clock @clk@ +-- +-- __NB__: The constructor, @(':-')@, is __not__ synthesisable. +data CSignal (clk :: Clock) a = a :- CSignal clk a + +instance Show a => Show (CSignal clk a) where + show (x :- xs) = show x ++ " " ++ show xs + +instance Lift a => Lift (CSignal clk a) where + lift ~(x :- _) = [| signal# x |] + +instance Default a => Default (CSignal clk a) where + def = signal# def + +instance Functor (CSignal clk) where + fmap = mapSignal# + +{-# NOINLINE mapSignal# #-} +mapSignal# :: (a -> b) -> CSignal clk a -> CSignal clk b +mapSignal# f (a :- as) = f a :- mapSignal# f as + +instance Applicative (CSignal clk) where + pure = signal# + (<*>) = appSignal# + +{-# NOINLINE signal# #-} +signal# :: a -> CSignal clk a +signal# a = let s = a :- s in s + +{-# NOINLINE appSignal# #-} +appSignal# :: CSignal clk (a -> b) -> CSignal clk a -> CSignal clk b +appSignal# (f :- fs) ~(a :- as) = f a :- appSignal# fs as + +instance Num a => Num (CSignal clk a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = signal# . fromInteger + +-- | __NB__: Not synthesisable +-- +-- __NB__: In \"@'foldr' f z s@\": +-- +-- * The function @f@ should be /lazy/ in its second argument. +-- * The @z@ element will never be used. +instance Foldable (CSignal clk) where + foldr = foldr# + +{-# NOINLINE foldr# #-} +-- | __NB__: Not synthesisable +-- +-- __NB__: In \"@'foldr#' f z s@\": +-- +-- * The function @f@ should be /lazy/ in its second argument. +-- * The @z@ element will never be used. +foldr# :: (a -> b -> b) -> b -> CSignal clk a -> b +foldr# f z (a :- s) = a `f` (foldr# f z s) + +instance Traversable (CSignal clk) where + traverse = traverse# + +{-# NOINLINE traverse# #-} +traverse# :: Applicative f => (a -> f b) -> CSignal clk a -> f (CSignal clk b) +traverse# f (a :- s) = (:-) <$> f a <*> traverse# f s + +infixr 2 .||. +-- | Version of ('||') that returns a 'CSignal' of 'Bool' +(.||.) :: CSignal clk Bool -> CSignal clk Bool -> CSignal clk Bool +(.||.) = liftA2 (||) + +infixr 3 .&&. +-- | Version of ('&&') that returns a 'CSignal' of 'Bool' +(.&&.) :: CSignal clk Bool -> CSignal clk Bool -> CSignal clk Bool +(.&&.) = liftA2 (&&) + +-- | Version of 'not' that operates on 'CSignal's of 'Bool' +not1 :: CSignal clk Bool -> CSignal clk Bool +not1 = fmap not + +{-# NOINLINE register# #-} +register# :: SClock clk -> a -> CSignal clk a -> CSignal clk a +register# _ i s = i :- s + +{-# NOINLINE regEn# #-} +regEn# :: SClock clk -> a -> CSignal clk Bool -> CSignal clk a -> CSignal clk a +regEn# clk i b s = r + where + r = register# clk i s' + s' = mux b s r + +{-# INLINE mux #-} +-- | A multiplexer. Given "@'mux' b t f@", output @t@ when @b@ is 'True', and @f@ +-- when @b@ is 'False'. +mux :: CSignal clk Bool -> CSignal clk a -> CSignal clk a -> CSignal clk a +mux = liftA3 (\b t f -> if b then t else f) + +instance Bounded a => Bounded (CSignal clk a) where + minBound = signal# minBound + maxBound = signal# maxBound + +instance ExtendingNum a b => ExtendingNum (CSignal clk a) (CSignal clk b) where + type AResult (CSignal clk a) (CSignal clk b) = CSignal clk (AResult a b) + plus = liftA2 plus + minus = liftA2 minus + type MResult (CSignal clk a) (CSignal clk b) = CSignal clk (MResult a b) + times = liftA2 times + +instance SaturatingNum a => SaturatingNum (CSignal clk a) where + satPlus s = liftA2 (satPlus s) + satMin s = liftA2 (satMin s) + satMult s = liftA2 (satMult s) + +-- | __WARNING__: ('==') and ('/=') are undefined, use ('.==.') and ('./=.') +-- instead +instance Eq (CSignal clk a) where + (==) = error "(==)' undefined for 'CSignal', use '(.==.)' instead" + (/=) = error "(/=)' undefined for 'CSignal', use '(./=.)' instead" + +infix 4 .==. +-- | Version of ('==') that returns a 'CSignal' of 'Bool' +(.==.) :: Eq a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(.==.) = liftA2 (==) + +infix 4 ./=. +-- | Version of ('/=') that returns a 'CSignal' of 'Bool' +(./=.) :: Eq a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(./=.) = liftA2 (/=) + +-- | __WARNING__: 'compare', ('<'), ('>='), ('>'), and ('<=') are +-- undefined, use 'compare1', ('.<.'), ('.>=.'), ('.>.'), and ('.<=.') instead +instance Ord a => Ord (CSignal clk a) where + compare = error "'compare' undefined for 'CSignal', use 'compare1' instead" + (<) = error "'(<)' undefined for 'CSignal', use '(.<.)' instead" + (>=) = error "'(>=)' undefined for 'CSignal', use '(.>=.)' instead" + (>) = error "'(>)' undefined for 'CSignal', use '(.>.)' instead" + (<=) = error "'(<=)' undefined for 'CSignal', use '(.<=.)' instead" + max = liftA2 max + min = liftA2 min + +-- | Version of 'compare' that returns a 'CSignal' of 'Ordering' +compare1 :: Ord a => CSignal clk a -> CSignal clk a -> CSignal clk Ordering +compare1 = liftA2 compare + +infix 4 .<. +-- | Version of ('<') that returns a 'CSignal' of 'Bool' +(.<.) :: Ord a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(.<.) = liftA2 (<) + +infix 4 .<=. +-- | Version of ('<=') that returns a 'CSignal' of 'Bool' +(.<=.) :: Ord a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(.<=.) = liftA2 (<=) + +infix 4 .>. +-- | Version of ('>') that returns a 'CSignal' of 'Bool' +(.>.) :: Ord a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(.>.) = liftA2 (>) + +infix 4 .>=. +-- | Version of ('>=') that returns a 'CSignal' of 'Bool' +(.>=.) :: Ord a => CSignal clk a -> CSignal clk a -> CSignal clk Bool +(.>=.) = liftA2 (>=) + +-- | __WARNING__: 'fromEnum' is undefined, use 'fromEnum1' instead +instance Enum a => Enum (CSignal clk a) where + succ = fmap succ + pred = fmap pred + toEnum = signal# . toEnum + fromEnum = error "'fromEnum' undefined for 'CSignal', use 'fromEnum1'" + enumFrom = sequenceA . fmap enumFrom + enumFromThen = (sequenceA .) . liftA2 enumFromThen + enumFromTo = (sequenceA .) . liftA2 enumFromTo + enumFromThenTo = ((sequenceA .) .) . liftA3 enumFromThenTo + +-- | Version of 'fromEnum' that returns a 'CSignal' of 'Int' +fromEnum1 :: Enum a => CSignal clk a -> CSignal clk Int +fromEnum1 = fmap fromEnum + +-- | __WARNING__: 'toRational' is undefined, use 'toRational1' instead +instance (Num a, Ord a) => Real (CSignal clk a) where + toRational = error "'toRational' undefined for 'CSignal', use 'toRational1'" + +-- | Version of 'toRational' that returns a 'CSignal' of 'Rational' +toRational1 :: Real a => CSignal clk a -> CSignal clk Rational +toRational1 = fmap toRational + +-- | __WARNING__: 'toInteger' is undefined, use 'toInteger1' instead +instance Integral a => Integral (CSignal clk a) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem a b = (quot a b, rem a b) + divMod a b = (div a b, mod a b) + toInteger = error "'toInteger' undefined for 'CSignal', use 'toInteger1'" + +-- | Version of 'toRational' that returns a 'CSignal' of 'Integer' +toInteger1 :: Integral a => CSignal clk a -> CSignal clk Integer +toInteger1 = fmap toInteger + +-- | __WARNING__: 'testBit' and 'popCount' are undefined, use 'testBit1' and +-- 'popCount1' instead +instance Bits a => Bits (CSignal clk a) where + (.&.) = liftA2 (.&.) + (.|.) = liftA2 (.|.) + xor = liftA2 xor + complement = fmap complement + shift a i = fmap (`shift` i) a + rotate a i = fmap (`rotate` i) a + zeroBits = signal# zeroBits + bit = signal# . bit + setBit a i = fmap (`setBit` i) a + clearBit a i = fmap (`clearBit` i) a + testBit = error "'testBit' undefined for 'CSignal', use 'testbit1'" + bitSizeMaybe _ = bitSizeMaybe (undefined :: a) + bitSize _ = bitSize (undefined :: a) + isSigned _ = isSigned (undefined :: a) + shiftL a i = fmap (`shiftL` i) a + unsafeShiftL a i = fmap (`unsafeShiftL` i) a + shiftR a i = fmap (`shiftR` i) a + unsafeShiftR a i = fmap (`unsafeShiftR` i) a + rotateL a i = fmap (`rotateL` i) a + rotateR a i = fmap (`rotateR` i) a + popCount = error "'popCount' undefined for 'CSignal', use 'popCount1'" + +instance FiniteBits a => FiniteBits (CSignal clk a) where + finiteBitSize _ = finiteBitSize (undefined :: a) + +-- | Version of 'testBit' that has a 'CSignal' of 'Int' as indexing argument, +-- and a result of 'CSignal' of 'Bool' +testBit1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk Bool +testBit1 = liftA2 testBit + +-- | Version of 'popCount' that returns a 'CSignal' of 'Int' +popCount1 :: Bits a => CSignal clk a -> CSignal clk Int +popCount1 = fmap popCount + +-- | Version of 'shift' that has a 'CSignal' of 'Int' as indexing argument +shift1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +shift1 = liftA2 shift + +-- | Version of 'rotate' that has a 'CSignal' of 'Int' as indexing argument +rotate1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +rotate1 = liftA2 rotate + +-- | Version of 'setBit' that has a 'CSignal' of 'Int' as indexing argument +setBit1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +setBit1 = liftA2 setBit + +-- | Version of 'clearBit' that has a 'CSignal' of 'Int' as indexing argument +clearBit1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +clearBit1 = liftA2 clearBit + +-- | Version of 'shiftL' that has a 'CSignal' of 'Int' as indexing argument +shiftL1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +shiftL1 = liftA2 shiftL + +-- | Version of 'unsafeShiftL' that has a 'CSignal' of 'Int' as indexing argument +unsafeShiftL1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +unsafeShiftL1 = liftA2 unsafeShiftL + +-- | Version of 'shiftR' that has a 'CSignal' of 'Int' as indexing argument +shiftR1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +shiftR1 = liftA2 shiftR + +-- | Version of 'unsafeShiftR' that has a 'CSignal' of 'Int' as indexing argument +unsafeShiftR1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +unsafeShiftR1 = liftA2 unsafeShiftR + +-- | Version of 'rotateL' that has a 'CSignal' of 'Int' as indexing argument +rotateL1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +rotateL1 = liftA2 rotateL + +-- | Version of 'rotateR' that has a 'CSignal' of 'Int' as indexing argument +rotateR1 :: Bits a => CSignal clk a -> CSignal clk Int -> CSignal clk a +rotateR1 = liftA2 rotateR + +instance Fractional a => Fractional (CSignal clk a) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = signal# . fromRational diff --git a/src/CLaSH/Signal/Types.hs b/src/CLaSH/Signal/Types.hs deleted file mode 100644 --- a/src/CLaSH/Signal/Types.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} -module CLaSH.Signal.Types where - -import Data.Coerce (coerce) -import Data.Default (Default (..)) -import Control.Applicative (Applicative (..), liftA2) -import GHC.TypeLits (Nat) -import Language.Haskell.TH.Syntax (Lift (..)) - -import CLaSH.Promoted.Nat (SNat) - -infixr 5 :- --- | A synchronized signal with samples of type @a@, implicitly synchronized to --- an unnamed global clock -data Signal a = a :- Signal a - --- | A synchronized signal with samples of type @a@, explicitly synchronized to --- a clock with period @clk@ -newtype CSignal (clk :: Nat) a = CSignal (Signal a) - deriving (Show,Default,Lift,Functor,Applicative) - --- | A clock with period @clk@ -newtype Clock (clk :: Nat) = Clock (SNat clk) - -instance Show a => Show (Signal a) where - show (x :- xs) = show x ++ " " ++ show xs - -instance Lift a => Lift (Signal a) where - lift ~(x :- _) = [| signal x |] - -instance Default a => Default (Signal a) where - def = signal def - -{-# NOINLINE signal #-} -{-# NOINLINE mapSignal #-} -{-# NOINLINE appSignal #-} - --- | Create a constant 'Signal' from a combinational value --- --- >>> sample (signal 4) --- [4, 4, 4, 4, ... -signal :: a -> Signal a -signal a = let s = a :- s in s - -mapSignal :: (a -> b) -> Signal a -> Signal b -mapSignal f (a :- as) = f a :- mapSignal f as - -appSignal :: Signal (a -> b) -> Signal a -> Signal b -appSignal (f :- fs) ~(a :- as) = f a :- appSignal fs as - -instance Functor Signal where - fmap = mapSignal - -instance Applicative Signal where - pure = signal - (<*>) = appSignal - -shead :: Signal a -> a -shead (x :- _) = x - -stail :: Signal a -> Signal a -stail (_ :- xs) = xs - -mkCSignal :: a -> CSignal clk a -> CSignal clk a -mkCSignal a (CSignal s) = CSignal (a :- s) - -cstail :: CSignal t a -> CSignal t a -cstail (CSignal s) = CSignal (stail s) - --- | Create a constant 'CSignal' from a combinational value --- --- >>> csample (csignal 4) --- [4, 4, 4, 4, ... -csignal :: a -> CSignal t a -csignal a = coerce (signal a) - -instance Num a => Num (Signal a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = signal . fromInteger - -instance Num a => Num (CSignal t a) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - negate = fmap negate - abs = fmap abs - signum = fmap signum - fromInteger = csignal . fromInteger diff --git a/src/CLaSH/Sized/Fixed.hs b/src/CLaSH/Sized/Fixed.hs --- a/src/CLaSH/Sized/Fixed.hs +++ b/src/CLaSH/Sized/Fixed.hs @@ -1,22 +1,26 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fexpose-all-unfoldings -fno-strictness #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Fixed point numbers -- -- * The 'Num' operators for the given types saturate on overflow, -- and use truncation as the rounding method. --- --- * Use @$$('fLit' d)@ to create 'Fixed' point number literals. +-- * 'Fixed' has an instance for 'Fractional' meaning you use fractional +-- literals @(3.75 :: 'SFixed' 4 18)@. +-- * Both integer literals and fractional literals are clipped to 'minBound' and +-- 'maxBound'. +-- * There is no 'Floating' instance for 'Fixed', but you can use @$$('fLit' d)@ +-- to create 'Fixed' point literal from 'Double' constant at compile-time. -- * Use <#constraintsynonyms Constraint synonyms> when writing type signatures -- for polymorphic functions that use 'Fixed' point numbers. -- @@ -29,66 +33,79 @@ SFixed, sf, unSF -- * 'UFixed': 'Unsigned' 'Fixed' point numbers , UFixed, uf, unUF - -- * 'Fixed' point literals + -- * Division + , divide + -- * Compile-time 'Double' conversion , fLit -- * 'Fixed' point wrapper - , Fixed (..), resizeF, fracShift, satN2 + , Fixed (..), resizeF, fracShift -- * Constraint synonyms -- $constraintsynonyms -- ** Constraint synonyms for 'SFixed' - , NumSFixed, AddSFixed, MultSFixed, ResizeSFC + , NumSFixedC, ENumSFixedC, FracSFixedC, ResizeSFC, DivideSC -- ** Constraint synonyms for 'UFixed' - , NumUFixed, AddUFixed, MultUFixed, ResizeUFC + , NumUFixedC, ENumUFixedC, FracUFixedC, ResizeUFC, DivideUC -- ** Constraint synonyms for 'Fixed' wrapper - , NumFixed, AddFixed, MultFixed, ResizeFC, SatN2C - -- ** Constraint synonyms for 'Signed' and 'Unsigned' - , SatN2SC, SatN2UC + , NumFixedC, ENumFixedC, FracFixedC, ResizeFC, DivideC -- * Proxy - , asFracProxy, asRepProxy + , asRepProxy, asIntProxy ) where -import Control.Arrow -import Data.Bits -import Data.Default -import Data.List -import Data.Maybe -import Data.Proxy -import Data.Ratio -import Data.Typeable -import GHC.TypeLits -import Language.Haskell.TH -import Language.Haskell.TH.Syntax(Lift(..)) +import Control.Arrow ((***), second) +import Data.Bits (Bits (..)) +import Data.Default (Default (..)) +import Data.List (find) +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Data.Ratio ((%), denominator, numerator) +import Data.Typeable (Typeable, TypeRep, typeRep) +import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, mkName, + numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift(..)) -import CLaSH.Bit -import CLaSH.Class.BitVector -import CLaSH.Class.Num -import CLaSH.Promoted.Nat -import CLaSH.Promoted.Ord -import CLaSH.Sized.Signed -import CLaSH.Sized.Unsigned -import CLaSH.Sized.Vector +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), + SaturationMode (..), boundedPlus, boundedMin, + boundedMult) +import CLaSH.Class.Resize (Resize (..)) +import CLaSH.Promoted.Nat (SNat) +import CLaSH.Promoted.Ord (Max) +import CLaSH.Sized.Signed (Signed) +import CLaSH.Sized.Unsigned (Unsigned) -- | 'Fixed'-point number -- -- Where: -- --- * @frac@ denotes the position of the virtual @point@ counting from the LSB --- -- * @rep@ is the underlying representation -- --- * @size@ is the number of bits used to represent the number +-- * @int@ is the number of bits used to represent the integer part -- --- The 'Num' operators for this type saturate on overflow, --- and use truncation as the rounding method. -newtype Fixed (frac :: Nat) (rep :: Nat -> *) (size :: Nat) = Fixed { unFixed :: rep size } - deriving (Eq,Ord) +-- * @frac@ is the number of bits used to represent the fractional part +-- +-- The 'Num' operators for this type saturate to 'maxBound' on overflow and +-- 'minBound' on underflow, and use truncation as the rounding method. +newtype Fixed (rep :: Nat -> *) (int :: Nat) (frac :: Nat) = + Fixed { unFixed :: rep (int + frac) } +deriving instance Eq (rep (int + frac)) => Eq (Fixed rep int frac) +deriving instance Ord (rep (int + frac)) => Ord (Fixed rep int frac) +deriving instance Enum (rep (int + frac)) => Enum (Fixed rep int frac) +deriving instance Bounded (rep (int + frac)) => Bounded (Fixed rep int frac) +deriving instance Default (rep (int + frac)) => Default (Fixed rep int frac) + +-- | Instance functions do not saturate. +-- Meaning that \"@`'shiftL'` 1 == 'satMult' 'SatWrap' 2'@\"" +deriving instance Bits (rep (int + frac)) => Bits (Fixed rep int frac) + -- | Signed 'Fixed'-point number, with @int@ integer bits (including sign-bit) -- and @frac@ fractional bits. -- --- * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) .. 2^(@int@-1) - 2^-@frac@ ] +-- * The range 'SFixed' @int@ @frac@ numbers is: [-(2^(@int@ -1)) .. +-- 2^(@int@-1) - 2^-@frac@ ] -- * The resolution of 'SFixed' @int@ @frac@ numbers is: 2^@frac@ -- * The 'Num' operators for this type saturate on overflow, -- and use truncation as the rounding method. @@ -97,23 +114,24 @@ -- 3.9375 -- >>> minBound :: SFixed 3 4 -- -4.0 --- >>> (1 :: SFixed 3 4) + (2 :: SFixed 3 4) +-- >>> 1 + 2 :: SFixed 3 4 -- 3.0 --- >>> (2 :: SFixed 3 4) + (3 :: SFixed 3 4) +-- >>> 2 + 3 :: SFixed 3 4 -- 3.9375 --- >>> (-2 :: SFixed 3 4) + (-3 :: SFixed 3 4) +-- >>> (-2) + (-3) :: SFixed 3 4 -- -4.0 --- >>> ($$(fLit 1.375) :: SFixed 3 4) * ($$(fLit -0.8125) :: SFixed 3 4) +-- >>> 1.375 * (-0.8125) :: SFixed 3 4 -- -1.125 --- >>> ($$(fLit 1.375) :: SFixed 3 4) `mult` ($$(fLit -0.8125) :: SFixed 3 4) :: SFixed 6 8 +-- >>> (1.375 :: SFixed 3 4) `times` (-0.8125 :: SFixed 3 4) :: SFixed 6 8 -- -1.1171875 -- >>> (2 :: SFixed 3 4) `plus` (3 :: SFixed 3 4) :: SFixed 4 4 -- 5.0 -- >>> (-2 :: SFixed 3 4) `plus` (-3 :: SFixed 3 4) :: SFixed 4 4 -- -5.0 -type SFixed int frac = Fixed frac Signed (int + frac) +type SFixed = Fixed Signed --- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@ fractional bits +-- | Unsigned 'Fixed'-point number, with @int@ integer bits and @frac@ +-- fractional bits -- -- * The range 'UFixed' @int@ @frac@ numbers is: [0 .. 2^@int@ - 2^-@frac@ ] -- * The resolution of 'UFixed' @int@ @frac@ numbers is: 2^@frac@ @@ -124,15 +142,15 @@ -- 7.9375 -- >>> minBound :: UFixed 3 4 -- 0.0 --- >>> (1 :: UFixed 3 4) + (2 :: UFixed 3 4) +-- >>> 1 + 2 :: UFixed 3 4 -- 3.0 --- >>> (2 :: UFixed 3 4) + (6 :: UFixed 3 4) +-- >>> 2 + 6 :: UFixed 3 4 -- 7.9375 --- >>> (1 :: UFixed 3 4) - (3 :: UFixed 3 4) +-- >>> 1 - 3 :: UFixed 3 4 -- 0.0 --- >>> ($$(fLit 1.375) :: UFixed 3 4) * ($$(fLit 0.8125) :: UFixed 3 4) +-- >>> 1.375 * 0.8125 :: UFixed 3 4 -- 1.0625 --- >>> ($$(fLit 1.375) :: UFixed 3 4) `mult` ($$(fLit 0.8125) :: UFixed 3 4) :: UFixed 6 8 +-- >>> (1.375 :: UFixed 3 4) `times` (0.8125 :: UFixed 3 4) :: UFixed 6 8 -- 1.1171875 -- >>> (2 :: UFixed 3 4) `plus` (6 :: UFixed 3 4) :: UFixed 4 4 -- 8.0 @@ -141,8 +159,9 @@ -- -- >>> (1 :: UFixed 3 4) `minus` (3 :: UFixed 3 4) :: UFixed 4 4 -- 14.0 -type UFixed int frac = Fixed frac Unsigned (int + frac) +type UFixed = Fixed Unsigned +{-# INLINE sf #-} -- | Treat a 'Signed' integer as a @Signed@ 'Fixed'-@point@ integer -- -- >>> sf d4 (-22 :: Signed 7) @@ -152,11 +171,13 @@ -> SFixed int frac sf _ fRep = Fixed fRep +{-# INLINE unSF #-} -- | See the underlying representation of a Signed Fixed-point integer unSF :: SFixed int frac -> Signed (int + frac) unSF (Fixed fRep) = fRep +{-# INLINE uf #-} -- | Treat an 'Unsigned' integer as a @Unsigned@ 'Fixed'-@point@ number -- -- >>> uf d4 (92 :: Unsigned 7) @@ -166,27 +187,31 @@ -> UFixed int frac uf _ fRep = Fixed fRep +{-# INLINE unUF #-} -- | See the underlying representation of an Unsigned Fixed-point integer unUF :: UFixed int frac -> Unsigned (int + frac) unUF (Fixed fRep) = fRep -asFracProxy :: Fixed frac rep size -> Proxy frac -asFracProxy _ = Proxy - -asRepProxy :: Fixed frac rep size -> Proxy rep +{-# INLINE asRepProxy #-} +asRepProxy :: Fixed rep int frac -> Proxy rep asRepProxy _ = Proxy +{-# INLINE asIntProxy #-} +asIntProxy :: Fixed rep int frac -> Proxy int +asIntProxy _ = Proxy + -- | Get the position of the virtual @point@ of a 'Fixed'-@point@ number -fracShift :: KnownNat frac => Fixed frac rep size -> Int -fracShift f = fromInteger (natVal (asFracProxy f)) +fracShift :: KnownNat frac => Fixed rep int frac -> Int +fracShift fx = fromInteger (natVal fx) -instance ( Show (rep size), Bits (rep size), KnownNat frac +instance ( size ~ (int + frac), Show (rep size), Bits (rep size), KnownNat frac , Integral (rep size) - ) => Show (Fixed frac rep size) where - show f@(Fixed fRep) = i ++ "." ++ (uncurry pad . second (show . numerator) . - fromJust . find ((==1) . denominator . snd) . - iterate (succ *** (*10)) . (,) 0 $ (nom % denom)) + ) => Show (Fixed rep int frac) where + show f@(Fixed fRep) = + i ++ "." ++ (uncurry pad . second (show . numerator) . + fromJust . find ((==1) . denominator . snd) . + iterate (succ *** (*10)) . (,) 0 $ (nom % denom)) where pad n str = replicate (n - length str) '0' ++ str @@ -208,9 +233,12 @@ lines of constraints: @ -mac :: ( 1 <= (int + frac), (((int + frac) + 1) + 1) ~ ((int + frac) + 2) - , KnownNat (frac + frac), KnownNat ((int + frac) + (int + frac)) - , KnownNat ((int + frac) + 2), KnownNat (int + frac), KnownNat frac +mac :: ( KnownNat frac + , KnownNat (frac + frac) + , KnownNat (int + frac) + , KnownNat (1 + (int + frac)) + , KnownNat ((int + frac) + (int + frac)) + , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac)) ) => SFixed int frac -> SFixed int frac @@ -222,169 +250,239 @@ But with constraint synonyms, you can write the type signature like this: @ -mac :: NumSFixed int frac +mac1 :: 'NumSFixedC' int frac => SFixed int frac -> SFixed int frac -> SFixed int frac -> SFixed int frac -mac s x y = s + (x * y) +mac1 s x y = s + (x * y) @ -Where 'NumSFixed' refers to the @Constraints@ needed by the operators of +Where 'NumSFixedC' refers to the @Constraints@ needed by the operators of the 'Num' class for the 'SFixed' datatype. --} --- | Constraint for the 'Mult' instance of 'Fixed' -type MultFixed rep (frac1 :: Nat) (frac2 :: Nat) (size1 :: Nat) (size2 :: Nat) - = ( Mult (rep size1) (rep size2) - , MResult (rep size1) (rep size2) ~ rep (size1 + size2) - ) +Although the number of constraints for the @mac@ function defined earlier might +be considered small, here is an \"this way lies madness\" example where you +really want to use constraint kinds: --- | Constraint for the 'Mult' instance of 'SFixed' -type MultSFixed int1 frac1 int2 frac2 = MultFixed Signed frac1 frac2 (int1 + frac1) (int2 + frac2) +@ +mac2 :: ( KnownNat frac1 + , KnownNat frac2 + , KnownNat frac3 + , KnownNat (Max frac1 frac2) + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) + , KnownNat (int3 + frac3) + , KnownNat (frac1 + frac2) + , KnownNat (Max (frac1 + frac2) frac3) + , KnownNat (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3)) + , KnownNat ((int1 + int2) + (frac1 + frac2)) + , KnownNat (1 + Max (int1 + frac1) (int2 + frac2)) + , KnownNat (1 + Max (int1 + int2) int3 + Max (frac1 + frac2) frac3) + , KnownNat ((1 + Max int1 int2) + Max frac1 frac2) + , KnownNat ((1 + Max ((int1 + int2) + (frac1 + frac2)) (int3 + frac3))) + , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2)) + , (((int1 + int2) + int3) + ((frac1 + frac2) + frac3)) ~ (((int1 + int2) + (frac1 + frac2)) + (int3 + frac3)) + ) + => SFixed int1 frac1 + -> SFixed int2 frac2 + -> SFixed int3 frac3 + -> SFixed (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3) +mac2 x y s = (x \`times\` y) \`plus\` s +@ --- | Constraint for the 'Mult' instance of 'UFixed' -type MultUFixed int1 frac1 int2 frac2 = MultFixed Unsigned frac1 frac2 (int1 + frac1) (int2 + frac2) +Which, with the proper constraint kinds can be reduced to: --- | When used in a polymorphic setting, use the following --- for less verbose type signatures: --- --- * @'MultFixed' rep frac1 frac2 size1 size2@ for: 'Fixed' --- * @'MultSFixed' int1 frac1 int2 frac2@ for: 'SFixed' --- * @'MultUFixed' int1 frac1 int2 frac2@ for: 'UFixed' -instance MultFixed rep frac1 frac2 size1 size2 => Mult (Fixed frac1 rep size1) (Fixed frac2 rep size2) where - type MResult (Fixed frac1 rep size1) (Fixed frac2 rep size2) = Fixed (frac1 + frac2) rep (size1 + size2) - mult (Fixed fRep1) (Fixed fRep2) = Fixed (mult fRep1 fRep2) +@ +mac3 :: ( 'ENumSFixedC' int1 frac1 int2 frac2 + , 'ENumSFixedC' (int1 + int2) (frac1 + frac2) int3 frac3 + ) + => SFixed int1 frac1 + -> SFixed int2 frac2 + -> SFixed int3 frac3 + -> SFixed (1 + Max (int1 + int2) int3) (Max (frac1 + frac2) frac3) +mac3 x y s = (x \`times\` y) \`plus\` s +@ +-} --- | Constraint for the 'Add' instance of 'Fixed' -type AddFixed rep (frac1 :: Nat) (frac2 :: Nat) (size1 :: Nat) (size2 :: Nat) - = ( ResizeFC rep frac1 (Max frac1 frac2) size1 ((Max size1 size2) + 1) - , ResizeFC rep frac2 (Max frac1 frac2) size2 ((Max size1 size2) + 1) - , Num (rep (Max size1 size2 + 1)) +-- | Constraint for the 'ExtendingNum' instance of 'Fixed' +type ENumFixedC rep int1 frac1 int2 frac2 + = ( ResizeFC rep int1 frac1 (1 + Max int1 int2) (Max frac1 frac2) + , ResizeFC rep int2 frac2 (1 + Max int1 int2) (Max frac1 frac2) + , Bounded (rep ((1 + Max int1 int2) + Max frac1 frac2)) + , Num (rep ((1 + Max int1 int2) + Max frac1 frac2)) + , ExtendingNum (rep (int1 + frac1)) (rep (int2 + frac2)) + , MResult (rep (int1 + frac1)) (rep (int2 + frac2)) ~ + rep ((int1 + int2) + (frac1 + frac2)) ) --- | Constraint for the 'Add' instance of 'SFixed' -type AddSFixed int1 frac1 int2 frac2 = AddFixed Signed frac1 frac2 (int1 + frac1) (int2 + frac2) +-- | Constraint for the 'ExtendingNum' instance of 'SFixed' +type ENumSFixedC int1 frac1 int2 frac2 + = ( KnownNat frac1 + , KnownNat frac2 + , KnownNat (Max frac1 frac2) + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) + , KnownNat ((int1 + int2) + (frac1 + frac2)) + , KnownNat (1 + Max (int1 + frac1) (int2 + frac2)) + , KnownNat ((1 + Max int1 int2) + Max frac1 frac2) + , ((int1 + frac1) + (int2 + frac2)) ~ ((int1 + int2) + (frac1 + frac2)) + ) --- | Constraint for the 'Add' instance of 'UFixed' -type AddUFixed int1 frac1 int2 frac2 = AddFixed Unsigned frac1 frac2 (int1 + frac1) (int2 + frac2) +-- | Constraint for the 'ExtendingNum' instance of 'UFixed' +type ENumUFixedC int1 frac1 int2 frac2 = + ENumSFixedC int1 frac1 int2 frac2 --- | When used in a polymorphic setting, use the following --- for less verbose type signatures: +-- | When used in a polymorphic setting, use the following +-- for less +-- verbose type signatures: -- --- * @'AddFixed' rep frac1 frac2 size1 size2@ for: 'Fixed' --- * @'AddSFixed' int1 frac1 int2 frac2@ for: 'SFixed' --- * @'AddUFixed' int1 frac1 int2 frac2@ for: 'UFixed' -instance AddFixed rep frac1 frac2 size1 size2 => Add (Fixed frac1 rep size1) (Fixed frac2 rep size2) where - type AResult (Fixed frac1 rep size1) (Fixed frac2 rep size2) = Fixed (Max frac1 frac2) rep ((Max size1 size2) + 1) - plus f1 f2 = let (Fixed f1R) = resizeF f1 :: Fixed (Max frac1 frac2) rep ((Max size1 size2) + 1) - (Fixed f2R) = resizeF f2 :: Fixed (Max frac1 frac2) rep ((Max size1 size2) + 1) - in Fixed (f1R + f2R) - minus f1 f2 = let (Fixed f1R) = resizeF f1 :: Fixed (Max frac1 frac2) rep ((Max size1 size2) + 1) - (Fixed f2R) = resizeF f2 :: Fixed (Max frac1 frac2) rep ((Max size1 size2) + 1) - in Fixed (f1R - f2R) +-- * @'ENumFixedC' rep frac1 frac2 size1 size2@ for: 'Fixed' +-- * @'ENumSFixedC' int1 frac1 int2 frac2@ for: 'SFixed' +-- * @'ENumUFixedC' int1 frac1 int2 frac2@ for: 'UFixed' +instance ENumFixedC rep int1 frac1 int2 frac2 => + ExtendingNum (Fixed rep int1 frac1) (Fixed rep int2 frac2) where + type AResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = + Fixed rep (1 + Max int1 int2) (Max frac1 frac2) + plus f1 f2 = + let (Fixed f1R) = resizeF f1 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2) + (Fixed f2R) = resizeF f2 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2) + in Fixed (f1R + f2R) + minus f1 f2 = + let (Fixed f1R) = resizeF f1 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2) + (Fixed f2R) = resizeF f2 :: Fixed rep (1 + Max int1 int2) (Max frac1 frac2) + in Fixed (f1R - f2R) + type MResult (Fixed rep int1 frac1) (Fixed rep int2 frac2) = + Fixed rep (int1 + int2) (frac1 + frac2) + times (Fixed fRep1) (Fixed fRep2) = Fixed (times fRep1 fRep2) -- | Constraint for the 'Num' instance of 'Fixed' -type NumFixed (frac :: Nat) rep (size :: Nat) - = ( SatN2C rep size - , ResizeFC rep (frac + frac) frac (size + size) size - , Num (rep size) - , Num (rep (size + 2)) - , Mult (rep size) (rep size) - , MResult (rep size) (rep size) ~ rep (size + size) +type NumFixedC rep int frac + = ( SaturatingNum (rep (int + frac)) + , ExtendingNum (rep (int + frac)) (rep (int + frac)) + , ResizeFC rep (int + int) (frac + frac) int frac + , MResult (rep (int + frac)) (rep (int + frac)) ~ + rep ((int + int) + (frac + frac)) ) -- | Constraint for the 'Num' instance of 'SFixed' -type NumSFixed int frac = ( 1 <= (int + frac), (((int + frac) + 1) + 1) ~ ((int + frac) + 2) - , KnownNat (frac + frac), KnownNat ((int + frac) + (int + frac)) - , KnownNat ((int + frac) + 2), KnownNat (int + frac), KnownNat frac - ) +type NumSFixedC int frac = + ( KnownNat frac + , KnownNat (frac + frac) + , KnownNat (int + frac) + , KnownNat (1 + (int + frac)) + , KnownNat ((int + frac) + (int + frac)) + , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac)) + ) -- | Constraint for the 'Num' instance of 'UFixed' -type NumUFixed int frac = ( 1 <= (int + frac), (((int + frac) + 1) + 1) ~ ((int + frac) + 2) - , KnownNat (frac + frac), KnownNat ((int + frac) + (int + frac)) - , KnownNat ((int + frac) + 2), KnownNat (int + frac), KnownNat frac - ) +type NumUFixedC int frac = + NumSFixedC int frac --- | The operators of this instance saturate on overflow, and use truncation as the rounding method. +-- | The operators of this instance saturate on overflow, and use truncation as +-- the rounding method. -- --- When used in a polymorphic setting, use the following --- for less verbose type signatures: +-- When used in a polymorphic setting, use the following +-- for less +-- verbose type signatures: -- --- * @'NumFixed' frac rep size@ for: @'Fixed' frac rep size@ --- * @'NumSFixed' int frac@ for: @'SFixed' int frac@ --- * @'NumUFixed' int frac@ for: @'UFixed' int frac@ -instance (NumFixed frac rep size) => Num (Fixed frac rep size) where - (Fixed a) + (Fixed b) = Fixed (satN2 (resize a + resize b)) - (Fixed a) * (Fixed b) = resizeF (Fixed (a `mult` b) :: Fixed (frac + frac) rep (size + size)) - (Fixed a) - (Fixed b) = Fixed (satN2 (resize a - resize b)) - negate (Fixed a) = Fixed (satN2 (negate (resize a))) - abs (Fixed a) = Fixed (satN2 (abs (resize a))) - signum (Fixed a) = Fixed (signum a) - fromInteger i = let fSH = fromInteger (natVal (Proxy :: Proxy frac)) - res = Fixed (fromInteger i `shiftL` fSH) - in res - -instance (BitVector (rep size)) => BitVector (Fixed frac rep size) where - type BitSize (Fixed frac rep size) = BitSize (rep size) - toBV (Fixed fRep) = toBV fRep - fromBV bv = Fixed (fromBV bv) - -instance (Lift (rep size), KnownNat frac, KnownNat size, Typeable rep) => - Lift (Fixed frac rep size) where - lift f@(Fixed fRep) = sigE [| Fixed fRep |] (decFixed (natVal (asFracProxy f)) (typeRep (asRepProxy f)) (natVal f)) +-- * @'NumFixedC' frac rep size@ for: @'Fixed' frac rep size@ +-- * @'NumSFixedC' int frac@ for: @'SFixed' int frac@ +-- * @'NumUFixedC' int frac@ for: @'UFixed' int frac@ +instance (NumFixedC rep int frac) => Num (Fixed rep int frac) where + (+) = boundedPlus + (*) = boundedMult + (-) = boundedMin + negate (Fixed a) = Fixed (negate a) + abs (Fixed a) = Fixed (abs a) + signum (Fixed a) = Fixed (signum a) + fromInteger i = let fSH = fromInteger (natVal (Proxy :: Proxy frac)) + res = Fixed (fromInteger i `shiftL` fSH) + in res -decFixed :: Integer -> TypeRep -> Integer -> TypeQ -decFixed f r s = do - foldl appT (conT ''Fixed) [litT (numTyLit f), conT (mkName (show r)), litT (numTyLit s)] +instance (BitPack (rep (int + frac))) => BitPack (Fixed rep int frac) where + type BitSize (Fixed rep int frac) = BitSize (rep (int + frac)) + pack (Fixed fRep) = pack fRep + unpack bv = Fixed (unpack bv) -instance Default (rep size) => Default (Fixed frac rep size) where - def = Fixed def +instance (Lift (rep (int + frac)), KnownNat frac, KnownNat int, Typeable rep) => + Lift (Fixed rep int frac) where + lift f@(Fixed fRep) = sigE [| Fixed fRep |] + (decFixed (typeRep (asRepProxy f)) + (natVal (asIntProxy f)) + (natVal f)) -instance Bounded (rep size) => Bounded (Fixed frac rep size) where - minBound = Fixed minBound - maxBound = Fixed maxBound +decFixed :: TypeRep -> Integer -> Integer -> TypeQ +decFixed r i f = do + foldl appT (conT ''Fixed) [ conT (mkName (show r)) + , litT (numTyLit i) + , litT (numTyLit f) + ] -- | Constraint for the 'resizeF' function -type ResizeFC rep frac1 frac2 size1 size2 - = ( Bounded (rep size2), Eq (rep size1), Ord (rep size1) - , Num (rep size1), Bits (rep size1), Resize rep - , KnownNat size2, KnownNat size1, Bits (rep size2) - , KnownNat frac2, KnownNat frac1, Bounded (rep size1) +type ResizeFC rep int1 frac1 int2 frac2 + = ( Resize rep + , Ord (rep (int1 + frac1)) + , Num (rep (int1 + frac1)) + , Bits (rep (int1 + frac1)) + , Bits (rep (int2 + frac2)) + , KnownNat frac1 + , KnownNat frac2 + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) ) -- | Constraint for the 'resizeF' function, specialized for 'SFixed' -type ResizeSFC int1 frac1 int2 frac2 = (KnownNat (int2 + frac2), KnownNat (int1 + frac1), KnownNat frac1, KnownNat frac2) +type ResizeSFC int1 frac1 int2 frac2 + = ( KnownNat frac1 + , KnownNat frac2 + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) + ) -- | Constraint for the 'resizeF' function, specialized for 'UFixed' -type ResizeUFC int1 frac1 int2 frac2 = (KnownNat (int2 + frac2), KnownNat (int1 + frac1), KnownNat frac1, KnownNat frac2) +type ResizeUFC int1 frac1 int2 frac2 = + ResizeSFC int1 frac1 int2 frac2 +{-# INLINE resizeF #-} -- | Saturating resize operation, truncates for rounding -- --- >>> $$(fLit 0.8125) :: SFixed 3 4 +-- >>> 0.8125 :: SFixed 3 4 -- 0.8125 --- >>> resizeF ($$(fLit 0.8125) :: SFixed 3 4) :: SFixed 2 3 +-- >>> resizeF (0.8125 :: SFixed 3 4) :: SFixed 2 3 -- 0.75 --- >>> $$(fLit 3.4) :: SFixed 3 4 +-- >>> 3.4 :: SFixed 3 4 -- 3.375 --- >>> resizeF ($$(fLit 3.4) :: SFixed 3 4) :: SFixed 2 3 +-- >>> resizeF (3.4 :: SFixed 3 4) :: SFixed 2 3 -- 1.875 -- >>> maxBound :: SFixed 2 3 -- 1.875 -- --- When used in a polymorphic setting, use the following <#constraintsynonyms Constraint synonyms> --- for less verbose type signatures: +-- When used in a polymorphic setting, use the following +-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures: -- --- * @'ResizeFC' rep frac1 frac2 size1 size2@ for: @'Fixed' frac1 rep size1 -> 'Fixed' frac2 rep size2@ --- * @'ResizeSFC' int1 frac1 int2 frac2@ for: @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@ --- * @'ResizeUFC' int1 frac1 int2 frac2@ for: @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@ -resizeF :: forall frac1 frac2 rep size1 size2 . - ResizeFC rep frac1 frac2 size1 size2 - => Fixed frac1 rep size1 - -> Fixed frac2 rep size2 -resizeF (Fixed fRep) = Fixed sat +-- * @'ResizeFC' rep int1 frac1 int2 frac2@ for: +-- @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2@ +-- +-- * @'ResizeSFC' int1 frac1 int2 frac2@ for: +-- @'SFixed' int1 frac1 -> 'SFixed' int2 frac2@ +-- +-- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for: +-- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@ +resizeF ::(ResizeFC rep int1 frac1 int2 frac2, Bounded (rep (int2 + frac2))) + => Fixed rep int1 frac1 + -> Fixed rep int2 frac2 +resizeF = resizeF' False minBound maxBound + +resizeF' :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 int2 frac2 + => Bool -- ^ Wrap + -> rep (int2 + frac2) -- ^ minBound + -> rep (int2 + frac2) -- ^ maxBound + -> Fixed rep int1 frac1 + -> Fixed rep int2 frac2 +resizeF' doWrap fMin fMax (Fixed fRep) = Fixed sat where - argSZ = natVal (Proxy :: Proxy size1) - resSZ = natVal (Proxy :: Proxy size2) + argSZ = natVal (Proxy :: Proxy (int1 + frac1)) + resSZ = natVal (Proxy :: Proxy (int2 + frac2)) argFracSZ = fromInteger (natVal (Proxy :: Proxy frac1)) resFracSZ = fromInteger (natVal (Proxy :: Proxy frac2)) @@ -397,24 +495,24 @@ then resize fRep `shiftL` (resFracSZ - argFracSZ) else resize fRep `shiftR` (argFracSZ - resFracSZ) -- if the argument is bigger than the result, shift before resize - else let fMax = maxBound - fMin = minBound - mask = complement (resize fMax) :: rep size1 + else let mask = complement (resize fMax) :: rep (int1 + frac1) in if argFracSZ <= resFracSZ - then let shiftedL = fRep `shiftL` (resFracSZ - argFracSZ) + then let shiftedL = fRep `shiftL` + (resFracSZ - argFracSZ) shiftedL_masked = shiftedL .&. mask shiftedL_resized = resize shiftedL - in if fRep >= 0 + in if doWrap then shiftedL_resized else if fRep >= 0 then if shiftedL_masked == 0 then shiftedL_resized else fMax else if shiftedL_masked == mask then shiftedL_resized else fMin - else let shiftedR = fRep `shiftR` (argFracSZ - resFracSZ) + else let shiftedR = fRep `shiftR` + (argFracSZ - resFracSZ) shiftedR_masked = shiftedR .&. mask shiftedR_resized = resize shiftedR - in if fRep >= 0 + in if doWrap then shiftedR_resized else if fRep >= 0 then if shiftedR_masked == 0 then shiftedR_resized else fMax @@ -422,93 +520,41 @@ then shiftedR_resized else fMin --- | Constraint for the 'satN2' function -type SatN2C rep n - = ( 1 <= n - , ((n + 1) + 1) ~ (n + 2) - , BitVector (rep n) - , BitVector (rep (n + 2)) - , BitSize (rep n) ~ n - , BitSize (rep (n + 2)) ~ (n + 2) - , KnownNat n - , KnownNat (n + 2) - , Bounded (rep n) - , Bits (rep (n + 2)) - ) - --- | Constraint for the 'satN2' function, specialized for 'Signed' -type SatN2SC n = (1 <= n, ((n + 1) + 1) ~ (n + 2), KnownNat n, KnownNat (n + 2)) - --- | Constraint for the 'satN2' function, specialized for 'Unsigned' -type SatN2UC n = (1 <= n, ((n + 1) + 1) ~ (n + 2), KnownNat n, KnownNat (n + 2)) - --- | Resize an (N+2)-bits number to an N-bits number, saturates to --- 'minBound' or 'maxBound' when the argument does not fit within --- the representations bounds of the result. --- --- Uses cheaper saturation than 'resizeF', which is made possible by knowing --- that we only reduce the size by 2 bits. --- --- >>> (2 :: Unsigned 2) + (3 :: Unsigned 2) --- 1 --- >>> satN2 (resize (2 :: Unsigned 2) + resize (3 :: Unsigned 2)) :: Unsigned 2 --- 3 --- >>> satN2 (resize (1 :: Unsigned 2) + resize (1 :: Unsigned 2)) :: Unsigned 2 --- 2 --- >>> (2 :: Unsigned 2) - (3 :: Unsigned 2) --- 3 --- >>> satN2 (resize (2 :: Unsigned 2) - resize (3 :: Unsigned 2)) :: Unsigned 2 --- 0 --- >>> (2 :: Signed 3) + (3 :: Signed 3) --- -3 --- >>> satN2 (resize (2 :: Signed 3) + resize (3 :: Signed 3)) :: Signed 3 --- 3 --- --- When used in a polymorphic setting, use the following <#constraintsynonyms Constraint synonyms> --- for less verbose type signatures: --- --- * 'SatN2C' for: @rep (n+2) -> rep n@ --- * 'SatN2SC' for: @'Signed' (n+2) -> 'Signed' n@ --- * 'SatN2UC' for: @'Unsigned' (n+2) -> 'Unsigned' n@ -satN2 :: SatN2C rep n - => rep (n + 2) - -> rep n -satN2 rep = if isSigned rep - then case (cS,sn) of - (L,H) -> maxBound - (H,L) -> minBound - _ -> fromBV s - else case (cS,cU) of - (H,H) -> minBound - (L,H) -> maxBound - _ -> fromBV s - where - repBV = toBV rep - cS = vhead repBV - cU = vhead (vtail repBV) - s = vtail (vtail repBV) - sn = vhead' s - --- | Convert, at compile-time, a 'Double' literal to a 'Fixed'-point literal. --- The conversion saturates on overflow, and uses truncation as its rounding method. +-- | Convert, at compile-time, a 'Double' /constant/ to a 'Fixed'-point /literal/. +-- The conversion saturates on overflow, and uses truncation as its rounding +-- method. -- -- So when you type: -- --- > n = $$(fLit 2.8672) :: SFixed 4 4 +-- > n = $$(fLit pi) :: SFixed 4 4 -- -- The compiler sees: -- --- > n = Fixed (fromInteger 45) :: SFixed 4 4 +-- > n = Fixed (fromInteger 50) :: SFixed 4 4 -- -- Upon evaluation you see that the value is rounded / truncated in accordance -- to the fixed point representation: -- -- >>> n --- 2.8125 -fLit :: forall frac rep size . - (KnownNat frac, Num (rep size), Bounded (rep size), Integral (rep size)) +-- 3.125 +-- +-- Further examples: +-- +-- >>> sin 0.5 :: Double +-- 0.479425538604203 +-- >>> $$(fLit (sin 0.5)) :: SFixed 1 8 +-- 0.4765625 +-- >>> atan 0.2 :: Double +-- 0.19739555984988078 +-- >>> $$(fLit (atan 0.2)) :: SFixed 1 8 +-- 0.1953125 +-- >>> $$(fLit (atan 0.2)) :: SFixed 1 20 +-- 0.19739532470703125 +fLit :: forall rep int frac size . + ( size ~ (int + frac), KnownNat frac, Num (rep size), Bounded (rep size) + , Integral (rep size)) => Double - -> Q (TExp (Fixed frac rep size)) + -> Q (TExp (Fixed rep int frac)) fLit a = [|| Fixed (fromInteger sat) ||] where rMax = toInteger (maxBound :: rep size) @@ -520,3 +566,115 @@ else truncated truncated = truncate shifted :: Integer shifted = a * (2 ^ (natVal (Proxy :: Proxy frac))) + + +instance NumFixedC rep int frac => SaturatingNum (Fixed rep int frac) where + satPlus w (Fixed a) (Fixed b) = Fixed (satPlus w a b) + satMin w (Fixed a) (Fixed b) = Fixed (satMin w a b) + satMult w (Fixed a) (Fixed b) = case w of + SatWrap -> resizeF' True 0 0 res + SatBound -> resizeF' False minBound maxBound res + SatZero -> resizeF' False 0 0 res + SatSymmetric -> resizeF' False fMinSym maxBound res + where + res = Fixed (a `times` b) :: Fixed rep (int + int) (frac + frac) + fMinSym = if isSigned a + then 0 + else minBound + 1 + +-- | Constraint for the 'divide' function +type DivideC rep int1 frac1 int2 frac2 + = ( Resize rep + , Integral (rep (((int1 + frac2) + 1) + (int2 + frac1))) + , Bits (rep (((int1 + frac2) + 1) + (int2 + frac1))) + , KnownNat int2 + , KnownNat frac2 + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) + , KnownNat ((int1 + frac2 + 1) + (int2 + frac1)) + ) + +-- | Constraint for the 'divide' function, specialized for 'SFixed' +type DivideSC int1 frac1 int2 frac2 + = ( KnownNat int2 + , KnownNat frac2 + , KnownNat (int1 + frac1) + , KnownNat (int2 + frac2) + , KnownNat ((int1 + frac2 + 1) + (int2 + frac1)) + ) + +-- | Constraint for the 'divide' function, specialized for 'UFixed' +type DivideUC int1 frac1 int2 frac2 = + DivideSC int1 frac1 int2 frac2 + +-- | Fixed point division +-- +-- When used in a polymorphic setting, use the following +-- <#constraintsynonyms Constraint synonyms> for less verbose type signatures: +-- +-- * @'DivideC' rep int1 frac1 int2 frac2@ for: +-- @'Fixed' rep int1 frac1 -> 'Fixed' rep int2 frac2 -> 'Fixed' rep (int1 + frac2 + 1) (int2 + frac1)@ +-- +-- * @'DivideSC' rep int1 frac1 int2 frac2@ for: +-- @'SFixed' int1 frac1 -> 'SFixed' int2 frac2 -> 'SFixed' (int1 + frac2 + 1) (int2 + frac1)@ +-- +-- * @'DivideUC' rep int1 frac1 int2 frac2@ for: +-- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2 -> 'UFixed' (int1 + frac2 + 1) (int2 + frac1)@ +divide :: DivideC rep int1 frac1 int2 frac2 + => Fixed rep int1 frac1 + -> Fixed rep int2 frac2 + -> Fixed rep (int1 + frac2 + 1) (int2 + frac1) +divide (Fixed fr1) fx2@(Fixed fr2) = Fixed res + where + int2 = fromInteger (natVal (asIntProxy fx2)) + frac2 = fromInteger (natVal fx2) + fr1' = resize fr1 + fr2' = resize fr2 + fr1SH = shiftL fr1' ((int2 + frac2)) + res = fr1SH `quot` fr2' + +-- | Constraint for the 'Fractional' instance of 'Fixed' +type FracFixedC rep int frac + = ( NumFixedC rep int frac + , DivideC rep int frac int frac + , Integral (rep (int + frac)) + ) + +-- | Constraint for the 'Fractional' instance of 'SFixed' +type FracSFixedC int frac + = ( NumSFixedC int frac + , KnownNat int + , KnownNat ((int + frac + 1) + (int + frac)) + ) + +-- | Constraint for the 'Fractional' instance of 'UFixed' +type FracUFixedC int frac + = FracSFixedC int frac + +-- | The operators of this instance saturate on overflow, and use truncation as +-- the rounding method. +-- +-- When used in a polymorphic setting, use the following +-- for less +-- verbose type signatures: +-- +-- * @'FracFixedC' frac rep size@ for: @'Fixed' frac rep size@ +-- * @'FracSFixedC' int frac@ for: @'SFixed' int frac@ +-- * @'FracUFixedC' int frac@ for: @'UFixed' int frac@ +instance (FracFixedC rep int frac) => Fractional (Fixed rep int frac) where + f1 / f2 = resizeF (divide f1 f2) + recip fx = resizeF (divide (1 :: Fixed rep int frac) fx) + fromRational r = res + where + res = Fixed (fromInteger sat) + sat = if res' > rMax + then rMax + else if res' < rMin then rMin else res' + + rMax = toInteger (maxBound :: rep (int + frac)) + rMin = toInteger (minBound :: rep (int + frac)) + res' = n `div` d + + frac = fromInteger (natVal res) + n = numerator r `shiftL` (2 * frac) + d = denominator r `shiftL` frac diff --git a/src/CLaSH/Sized/Index.hs b/src/CLaSH/Sized/Index.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Sized/Index.hs @@ -0,0 +1,5 @@ +module CLaSH.Sized.Index + (Index) +where + +import CLaSH.Sized.Internal.Index diff --git a/src/CLaSH/Sized/Internal/BitVector.hs b/src/CLaSH/Sized/Internal/BitVector.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Sized/Internal/BitVector.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module CLaSH.Sized.Internal.BitVector + ( -- * Datatypes + BitVector (..) + , Bit + -- * Accessors + -- ** Length information + , size# + , maxIndex# + -- * Construction + -- ** Initialisation + , high + , low + , bLit + -- ** Concatenation + , (++#) + -- * Reduction + , reduceAnd# + , reduceOr# + , reduceXor# + -- * Indexing + , index# + , replaceBit# + , setSlice# + , slice# + , split# + , msb# + , lsb# + -- * Type classes + -- ** Eq + , eq# + , neq# + -- ** Ord + , lt# + , ge# + , gt# + , le# + -- ** Enum (not synthesisable) + , enumFrom# + , enumFromThen# + , enumFromTo# + , enumFromThenTo# + -- ** Bounded + , minBound# + , maxBound# + -- ** Num + , (+#) + , (-#) + , (*#) + , negate# + , fromInteger# + -- ** ExtendingNum + , plus# + , minus# + , times# + -- ** Integral + , quot# + , rem# + , mod# + , toInteger# + -- ** Bits + , and# + , or# + , xor# + , complement# + , shiftL# + , shiftR# + , rotateL# + , rotateR# + , popCount# + -- ** Resize + , resize# + ) +where + +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Char (digitToInt) +import Data.Default (Default (..)) +import Data.Maybe (listToMaybe) +import Data.Typeable (Typeable) +import GHC.Integer (smallInteger) +import GHC.Prim (dataToTag#) +import GHC.TypeLits (KnownNat, Nat, type (+), type (-), natVal) +import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift(..)) +import Numeric (readInt) + +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), + SaturationMode (..)) +import CLaSH.Class.Resize (Resize (..)) +import CLaSH.Promoted.Nat (SNat, snatToInteger) +import CLaSH.Promoted.Ord (Max) + +-- * Type definitions + +-- | A vector of bits. +-- +-- * Bit indices are descending +-- * 'Num' instance performs /unsigned/ arithmetic. +newtype BitVector (n :: Nat) = + -- | The constructor, 'BV', and the field, 'unsafeToInteger', are not + -- synthesisable. + BV { unsafeToInteger :: Integer} + deriving Typeable + +type Bit = BitVector 1 + +-- * Instances +instance KnownNat n => Show (BitVector n) where + show bv@(BV i) = showBV (natVal bv) i [] + where + showBV 0 _ s = s + showBV n v s = let (a,b) = divMod v 2 + in case b of + 1 -> showBV (n - 1) a ('1':s) + _ -> showBV (n - 1) a ('0':s) + +-- | Create a binary literal +-- +-- >>> $$(bLit "1001") :: BitVector 4 +-- 1001 +-- >>> $$(bLit "1001") :: BitVector 3 +-- 001 +-- +-- __NB__: Will be removed once GHC 7.10 is released which has support for +-- binary literals. Once GHC 7.10 is released you can just write: +-- +-- >>> 0b1001 :: BitVector 4 +-- 1001 +bLit :: KnownNat n => String -> Q (TExp (BitVector n)) +bLit s = [|| fromInteger# i' ||] + where + i :: Maybe Integer + i = fmap fst . listToMaybe $ (readInt 2 (`elem` "01") digitToInt) s + + i' :: Integer + i' = case i of + Just j -> j + _ -> error "Failed to parse: " s + +instance Eq (BitVector n) where + (==) = eq# + (/=) = neq# + +{-# NOINLINE eq# #-} +eq# :: BitVector n -> BitVector n -> Bool +eq# (BV v1) (BV v2) = v1 == v2 + +{-# NOINLINE neq# #-} +neq# :: BitVector n -> BitVector n -> Bool +neq# (BV v1) (BV v2) = v1 /= v2 + +instance Ord (BitVector n) where + (<) = lt# + (>=) = ge# + (>) = gt# + (<=) = le# + +lt#,ge#,gt#,le# :: BitVector n -> BitVector n -> Bool +{-# NOINLINE lt# #-} +lt# (BV n) (BV m) = n < m +{-# NOINLINE ge# #-} +ge# (BV n) (BV m) = n >= m +{-# NOINLINE gt# #-} +gt# (BV n) (BV m) = n > m +{-# NOINLINE le# #-} +le# (BV n) (BV m) = n <= m + +-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and +-- 'enumFromThenTo', are not synthesisable. +instance KnownNat n => Enum (BitVector n) where + succ = (+# fromInteger# 1) + pred = (-# fromInteger# 1) + toEnum = fromInteger# . toInteger + fromEnum = fromEnum . toInteger# + enumFrom = enumFrom# + enumFromThen = enumFromThen# + enumFromTo = enumFromTo# + enumFromThenTo = enumFromThenTo# + +{-# NOINLINE enumFrom# #-} +{-# NOINLINE enumFromThen# #-} +{-# NOINLINE enumFromTo# #-} +{-# NOINLINE enumFromThenTo# #-} +enumFrom# :: KnownNat n => BitVector n -> [BitVector n] +enumFromThen# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] +enumFromTo# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] +enumFromThenTo# :: KnownNat n => BitVector n -> BitVector n -> BitVector n + -> [BitVector n] +enumFrom# x = map toEnum [fromEnum x ..] +enumFromThen# x y = map toEnum [fromEnum x, fromEnum y ..] +enumFromTo# x y = map toEnum [fromEnum x .. fromEnum y] +enumFromThenTo# x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] + +instance KnownNat n => Bounded (BitVector n) where + minBound = minBound# + maxBound = maxBound# + +{-# NOINLINE minBound# #-} +minBound# :: KnownNat n => BitVector n +minBound# = BV 0 + +{-# NOINLINE maxBound# #-} +maxBound# :: KnownNat n => BitVector n +maxBound# = let res = BV ((2 ^ natVal res) - 1) in res + +instance KnownNat n => Num (BitVector n) where + (+) = (+#) + (-) = (-#) + (*) = (*#) + negate = negate# + abs = id + signum bv = resize# (reduceOr# bv) + fromInteger = fromInteger# + +(+#),(-#),(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n +{-# NOINLINE (+#) #-} +(+#) (BV i) (BV j) = fromInteger_INLINE (i + j) + +{-# NOINLINE (-#) #-} +(-#) (BV i) (BV j) = fromInteger_INLINE (i - j) + +{-# NOINLINE (*#) #-} +(*#) (BV i) (BV j) = fromInteger_INLINE (i * j) + +{-# NOINLINE negate# #-} +negate# :: KnownNat n => BitVector n -> BitVector n +negate# bv@(BV i) = BV (sz - i) + where + sz = 2 ^ natVal bv + +{-# NOINLINE fromInteger# #-} +fromInteger# :: KnownNat n => Integer -> BitVector n +fromInteger# = fromInteger_INLINE + +{-# INLINE fromInteger_INLINE #-} +fromInteger_INLINE :: KnownNat n => Integer -> BitVector n +fromInteger_INLINE i = let res = BV (i `mod` (2 ^ natVal res)) in res + +instance (KnownNat (Max m n + 1), KnownNat (m + n)) => + ExtendingNum (BitVector m) (BitVector n) where + type AResult (BitVector m) (BitVector n) = BitVector (Max m n + 1) + plus = plus# + minus = minus# + type MResult (BitVector m) (BitVector n) = BitVector (m + n) + times = times# + +plus#, minus# :: KnownNat (Max m n + 1) => BitVector m -> BitVector n + -> BitVector (Max m n + 1) +{-# NOINLINE plus# #-} +plus# (BV a) (BV b) = fromInteger_INLINE (a + b) + +{-# NOINLINE minus# #-} +minus# (BV a) (BV b) = fromInteger_INLINE (a - b) + +{-# NOINLINE times# #-} +times# :: KnownNat (m + n) => BitVector m -> BitVector n -> BitVector (m + n) +times# (BV a) (BV b) = fromInteger_INLINE (a * b) + +instance KnownNat n => Real (BitVector n) where + toRational = toRational . toInteger# + +instance KnownNat n => Integral (BitVector n) where + quot = quot# + rem = rem# + div = quot# + mod = mod# + quotRem n d = (n `quot#` d,n `rem#` d) + divMod n d = (n `quot#` d,n `mod#` d) + toInteger = toInteger# + +quot#,rem#,mod# :: BitVector n -> BitVector n -> BitVector n +{-# NOINLINE quot# #-} +quot# (BV i) (BV j) = BV (i `quot` j) +{-# NOINLINE rem# #-} +rem# (BV i) (BV j) = BV (i `rem` j) +{-# NOINLINE mod# #-} +mod# (BV i) (BV j) = BV (i `mod` j) + +{-# NOINLINE toInteger# #-} +toInteger# :: BitVector n -> Integer +toInteger# (BV i) = i + +instance KnownNat n => Bits (BitVector n) where + (.&.) = and# + (.|.) = or# + xor = xor# + complement = complement# + zeroBits = 0 + bit i = replaceBit# 0 i high + setBit v i = replaceBit# v i high + clearBit v i = replaceBit# v i low + complementBit v i = replaceBit# v i (complement# (index# v i)) + testBit v i = eq# (index# v i) high + bitSizeMaybe v = Just (size# v) + bitSize = size# + isSigned _ = False + shiftL v i = shiftL# v i + shiftR v i = shiftR# v i + rotateL v i = rotateL# v i + rotateR v i = rotateR# v i + popCount = popCount# + +instance KnownNat n => FiniteBits (BitVector n) where + finiteBitSize = size# + +{-# NOINLINE reduceAnd# #-} +reduceAnd# :: (KnownNat n) => BitVector n -> BitVector 1 +reduceAnd# bv@(BV i) = BV (smallInteger (dataToTag# check)) + where + check = i == maxI + + sz = natVal bv + maxI = (2 ^ sz) - 1 + +{-# NOINLINE reduceOr# #-} +reduceOr# :: BitVector n -> BitVector 1 +reduceOr# (BV i) = BV (smallInteger (dataToTag# check)) + where + check = i /= 0 + +{-# NOINLINE reduceXor# #-} +reduceXor# :: BitVector n -> BitVector 1 +reduceXor# (BV i) = BV (toInteger (popCount i `mod` 2)) + +instance KnownNat n => Default (BitVector n) where + def = minBound# + +-- * Accessors +-- ** Length information +{-# NOINLINE size# #-} +size# :: KnownNat n => BitVector n -> Int +size# bv = fromInteger (natVal bv) + +{-# NOINLINE maxIndex# #-} +maxIndex# :: KnownNat n => BitVector n -> Int +maxIndex# bv = fromInteger (natVal bv) - 1 + +-- ** Indexing +{-# NOINLINE index# #-} +index# :: KnownNat n => BitVector n -> Int -> Bit +index# bv@(BV v) i + | i >= 0 && i < sz = BV (smallInteger + (dataToTag# + (testBit v i))) + | otherwise = err + where + sz = fromInteger (natVal bv) + err = error $ concat [ "(!): " + , show i + , " is out of range [" + , show (sz - 1) + , "..0]" + ] + +{-# NOINLINE msb# #-} +-- | MSB +msb# :: KnownNat n => BitVector n -> Bit +msb# bv@(BV v) = BV (smallInteger (dataToTag# (testBit v i))) + where + i = fromInteger (natVal bv - 1) + +{-# NOINLINE lsb# #-} +-- | LSB +lsb# :: BitVector n -> Bit +lsb# (BV v) = BV (smallInteger (dataToTag# (testBit v 0))) + +{-# NOINLINE slice# #-} +slice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) +slice# (BV i) m n = BV (shiftR (i .&. mask) n') + where + m' = snatToInteger m + n' = fromInteger (snatToInteger n) + + mask = 2 ^ (m' + 1) - 1 + +-- * Constructions +-- ** Initialisation +{-# NOINLINE high #-} +-- | logic '1' +high :: Bit +high = BV 1 + +{-# NOINLINE low #-} +-- | logic '0' +low :: Bit +low = BV 0 + +-- ** Concatenation +{-# NOINLINE (++#) #-} +-- | Concatenate two 'BitVector's +(++#) :: KnownNat m => BitVector n -> BitVector m -> BitVector (n + m) +(BV v1) ++# bv2@(BV v2) = BV (v1' + v2) + where + v1' = shiftL v1 (fromInteger (natVal bv2)) + +-- * Modifying BitVectors +{-# NOINLINE replaceBit# #-} +replaceBit# :: KnownNat n => BitVector n -> Int -> Bit -> BitVector n +replaceBit# bv@(BV v) i (BV b) + | i >= 0 && i < sz = BV (if b == 1 then setBit v i else clearBit v i) + | otherwise = err + where + sz = fromInteger (natVal bv) + err = error $ concat [ "replaceBit: " + , show i + , " is out of range [" + , show (sz - 1) + , "..0]" + ] + +{-# NOINLINE setSlice# #-} +setSlice# :: BitVector (m + 1 + i) -> SNat m -> SNat n -> BitVector (m + 1 - n) + -> BitVector (m + 1 + i) +setSlice# (BV i) m n (BV j) = BV ((i .&. mask) .|. j') + where + m' = snatToInteger m + n' = snatToInteger n + + j' = shiftL j (fromInteger n') + mask = complement ((2 ^ (m' + 1) - 1) `xor` (2 ^ n' - 1)) + +{-# NOINLINE split# #-} +split# :: KnownNat n => BitVector (m + n) -> (BitVector m, BitVector n) +split# (BV i) = (l,r) + where + n = fromInteger (natVal r) + mask = (2 ^ n) - 1 + r = BV (i .&. mask) + l = BV (i `shiftR` n) + +and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n +{-# NOINLINE and# #-} +and# (BV v1) (BV v2) = BV (v1 .&. v2) + +{-# NOINLINE or# #-} +or# (BV v1) (BV v2) = BV (v1 .|. v2) + +{-# NOINLINE xor# #-} +xor# (BV v1) (BV v2) = BV (v1 `xor` v2) + +{-# NOINLINE complement# #-} +complement# :: KnownNat n => BitVector n -> BitVector n +complement# (BV v1) = fromInteger_INLINE (complement v1) + +shiftL#, shiftR#, rotateL#, rotateR# :: KnownNat n => BitVector n -> Int + -> BitVector n +{-# NOINLINE shiftL# #-} +shiftL# (BV v) i + | i < 0 = error + $ "'shiftL undefined for negative number: " ++ show i + | otherwise = fromInteger_INLINE (shiftL v i) + +{-# NOINLINE shiftR# #-} +shiftR# (BV v) i + | i < 0 = error + $ "'shiftR undefined for negative number: " ++ show i + | otherwise = fromInteger_INLINE (shiftR v i) + +{-# NOINLINE rotateL# #-} +rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" +rotateL# bv@(BV n) b = fromInteger_INLINE (l .|. r) + where + l = shiftL n b' + r = shiftR n b'' + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal bv) + +{-# NOINLINE rotateR# #-} +rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" +rotateR# bv@(BV n) b = fromInteger_INLINE (l .|. r) + where + l = shiftR n b' + r = shiftL n b'' + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal bv) + +{-# NOINLINE popCount# #-} +popCount# :: BitVector n -> Int +popCount# (BV i) = popCount i + +instance Resize BitVector where + resize = resize# + zeroExtend = resize# + signExtend = resize# + truncateB = resize# + +{-# NOINLINE resize# #-} +resize# :: KnownNat m => BitVector n -> BitVector m +resize# (BV n) = fromInteger_INLINE n + +instance KnownNat n => Lift (BitVector n) where + lift bv@(BV i) = sigE [| fromInteger# i |] (decBitVector (natVal bv)) + +decBitVector :: Integer -> TypeQ +decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n) + +instance (KnownNat n, KnownNat (n + 1), KnownNat (n + n)) => + SaturatingNum (BitVector n) where + satPlus SatWrap a b = a +# b + satPlus w a b = case msb# r of + 0 -> resize# r + _ -> case w of + SatZero -> minBound# + _ -> maxBound# + where + r = plus# a b + + satMin SatWrap a b = a -# b + satMin _ a b = case msb# r of + 0 -> resize# r + _ -> minBound# + where + r = minus# a b + + satMult SatWrap a b = a *# b + satMult w a b = case rL of + 0 -> rR + _ -> case w of + SatZero -> minBound# + _ -> maxBound# + where + r = times# a b + (rL,rR) = split# r diff --git a/src/CLaSH/Sized/Internal/Index.hs b/src/CLaSH/Sized/Internal/Index.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Sized/Internal/Index.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +module CLaSH.Sized.Internal.Index + ( -- * Datatypes + Index (..) + -- * Type classes + -- ** Eq + , eq# + , neq# + -- ** Ord + , lt# + , ge# + , gt# + , le# + -- ** Enum (not synthesisable) + , enumFrom# + , enumFromThen# + , enumFromTo# + , enumFromThenTo# + -- ** Bounded + , maxBound# + -- ** Num + , (+#) + , (-#) + , (*#) + , fromInteger# + -- ** Integral + , quot# + , rem# + , mod# + , toInteger# + ) +where + +import Data.Default (Default (..)) +import Data.Typeable (Typeable) +import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift(..)) +import GHC.TypeLits (KnownNat, Nat, natVal) + +-- | Arbitrary-bounded unsigned integer represented by @ceil(log_2(n))@ bits. +-- +-- Given an upper bound @n@, an 'Index' @n@ number has a range of: [0 .. @n@-1] +newtype Index (n :: Nat) = + -- | The constructor, 'I', and the field, 'unsafeToInteger', are not + -- synthesisable. + I { unsafeToInteger :: Integer } + deriving Typeable + +instance Eq (Index n) where + (==) = eq# + (/=) = neq# + +{-# NOINLINE eq# #-} +eq# :: (Index n) -> (Index n) -> Bool +(I n) `eq#` (I m) = n == m + +{-# NOINLINE neq# #-} +neq# :: (Index n) -> (Index n) -> Bool +(I n) `neq#` (I m) = n /= m + +instance Ord (Index n) where + (<) = lt# + (>=) = ge# + (>) = gt# + (<=) = le# + +lt#,ge#,gt#,le# :: Index n -> Index n -> Bool +{-# NOINLINE lt# #-} +lt# (I n) (I m) = n < m +{-# NOINLINE ge# #-} +ge# (I n) (I m) = n >= m +{-# NOINLINE gt# #-} +gt# (I n) (I m) = n > m +{-# NOINLINE le# #-} +le# (I n) (I m) = n <= m + +-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and +-- 'enumFromThenTo', are not synthesisable. +instance KnownNat n => Enum (Index n) where + succ = (+# fromInteger# 1) + pred = (-# fromInteger# 1) + toEnum = fromInteger# . toInteger + fromEnum = fromEnum . toInteger# + enumFrom = enumFrom# + enumFromThen = enumFromThen# + enumFromTo = enumFromTo# + enumFromThenTo = enumFromThenTo# + +{-# NOINLINE enumFrom# #-} +{-# NOINLINE enumFromThen# #-} +{-# NOINLINE enumFromTo# #-} +{-# NOINLINE enumFromThenTo# #-} +enumFrom# :: KnownNat n => Index n -> [Index n] +enumFromThen# :: KnownNat n => Index n -> Index n -> [Index n] +enumFromTo# :: KnownNat n => Index n -> Index n -> [Index n] +enumFromThenTo# :: KnownNat n => Index n -> Index n -> Index n -> [Index n] +enumFrom# x = map toEnum [fromEnum x ..] +enumFromThen# x y = map toEnum [fromEnum x, fromEnum y ..] +enumFromTo# x y = map toEnum [fromEnum x .. fromEnum y] +enumFromThenTo# x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] + +instance KnownNat n => Bounded (Index n) where + minBound = fromInteger# 0 + maxBound = maxBound# + +{-# NOINLINE maxBound# #-} +maxBound# :: KnownNat n => Index n +maxBound# = let res = I (natVal res - 1) in res + +-- | Operators report an error on overflow and underflow +instance KnownNat n => Num (Index n) where + (+) = (+#) + (-) = (-#) + (*) = (*#) + negate = (maxBound# -#) + abs = id + signum i = if i == 0 then 0 else 1 + fromInteger = fromInteger# + +(+#),(-#),(*#) :: KnownNat n => Index n -> Index n -> Index n +{-# NOINLINE (+#) #-} +(+#) (I a) (I b) = fromInteger_INLINE $ a + b + +{-# NOINLINE (-#) #-} +(-#) (I a) (I b) = fromInteger_INLINE $ a - b + +{-# NOINLINE (*#) #-} +(*#) (I a) (I b) = fromInteger_INLINE $ a * b + +fromInteger#,fromInteger_INLINE :: KnownNat n => Integer -> Index n +{-# NOINLINE fromInteger# #-} +fromInteger# = fromInteger_INLINE +{-# INLINE fromInteger_INLINE #-} +fromInteger_INLINE i = + let bound = natVal res + i' = i `mod` bound + err = error (show i ++ " is out of bounds: [0.." ++ show (bound - 1) ++ "]") + res = if i' /= i then err else I i + in res + +instance KnownNat n => Real (Index n) where + toRational = toRational . toInteger# + +instance KnownNat n => Integral (Index n) where + quot = quot# + rem = rem# + div = quot# + mod = mod# + quotRem n d = (n `quot#` d,n `rem#` d) + divMod n d = (n `quot#` d,n `mod#` d) + toInteger = toInteger# + +quot#,rem#,mod# :: KnownNat n => Index n -> Index n -> Index n +{-# NOINLINE quot# #-} +(I a) `quot#` (I b) = I (a `div` b) +{-# NOINLINE rem# #-} +(I a) `rem#` (I b) = I (a `rem` b) +{-# NOINLINE mod# #-} +(I a) `mod#` (I b) = I (a `mod` b) + +{-# NOINLINE toInteger# #-} +toInteger# :: Index n -> Integer +toInteger# (I n) = n + +instance KnownNat n => Lift (Index n) where + lift u@(I i) = sigE [| fromInteger# i |] (decIndex (natVal u)) + +decIndex :: Integer -> TypeQ +decIndex n = appT (conT ''Index) (litT $ numTyLit n) + +instance Show (Index n) where + show (I n) = show n + +instance KnownNat n => Default (Index n) where + def = fromInteger# 0 diff --git a/src/CLaSH/Sized/Internal/Signed.hs b/src/CLaSH/Sized/Internal/Signed.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Sized/Internal/Signed.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module CLaSH.Sized.Internal.Signed + ( -- * Datatypes + Signed (..) + -- * Accessors + -- ** Length information + , size# + -- * Type classes + -- ** BitConvert + , pack# + , unpack# + -- Eq + , eq# + , neq# + -- ** Ord + , lt# + , ge# + , gt# + , le# + -- ** Enum (not synthesisable) + , enumFrom# + , enumFromThen# + , enumFromTo# + , enumFromThenTo# + -- ** Bounded + , minBound# + , maxBound# + -- ** Num + , (+#) + , (-#) + , (*#) + , negate# + , abs# + , fromInteger# + -- ** ExtendingNum + , plus# + , minus# + , times# + -- ** Integral + , quot# + , rem# + , div# + , mod# + , toInteger# + -- ** Bits + , and# + , or# + , xor# + , complement# + , shiftL# + , shiftR# + , rotateL# + , rotateR# + , popCount# + -- ** Resize + , resize# + , truncateB# + -- ** SaturatingNum + , minBoundSym# + ) +where + +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Default (Default (..)) +import Data.Typeable (Typeable) +import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift(..)) + +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), + SaturationMode (..)) +import CLaSH.Class.Resize (Resize (..)) +import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) +import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr) +import CLaSH.Promoted.Ord (Max) +import CLaSH.Sized.Internal.BitVector (BitVector (..), (++#), high, low) +import qualified CLaSH.Sized.Internal.BitVector as BV + +-- | Arbitrary-width signed integer represented by @n@ bits, including the sign +-- bit. +-- +-- Uses standard 2-complements representation. Meaning that, given @n@ bits, +-- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1] +-- +-- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want +-- saturation on overflow, check out the 'SaturatingNum' class. +newtype Signed (n :: Nat) = + -- | The constructor, 'S', and the field, 'unsafeToInteger', are not + -- synthesisable. + S { unsafeToInteger :: Integer} + deriving Typeable + +{-# NOINLINE size# #-} +size# :: KnownNat n => Signed n -> Int +size# bv = fromInteger (natVal bv) + +instance Show (Signed n) where + show (S n) = show n + +instance KnownNat n => BitPack (Signed n) where + type BitSize (Signed n) = n + pack = pack# + unpack = unpack# + +{-# NOINLINE pack# #-} +pack# :: KnownNat n => Signed n -> BitVector n +pack# s@(S i) = BV (i `mod` maxI) + where + maxI = 2 ^ natVal s + +{-# NOINLINE unpack# #-} +unpack# :: KnownNat n => BitVector n -> Signed n +unpack# (BV i) = fromInteger_INLINE i + +instance Eq (Signed n) where + (==) = eq# + (/=) = neq# + +{-# NOINLINE eq# #-} +eq# :: Signed n -> Signed n -> Bool +eq# (S v1) (S v2) = v1 == v2 + +{-# NOINLINE neq# #-} +neq# :: Signed n -> Signed n -> Bool +neq# (S v1) (S v2) = v1 /= v2 + +instance Ord (Signed n) where + (<) = lt# + (>=) = ge# + (>) = gt# + (<=) = le# + +lt#,ge#,gt#,le# :: Signed n -> Signed n -> Bool +{-# NOINLINE lt# #-} +lt# (S n) (S m) = n < m +{-# NOINLINE ge# #-} +ge# (S n) (S m) = n >= m +{-# NOINLINE gt# #-} +gt# (S n) (S m) = n > m +{-# NOINLINE le# #-} +le# (S n) (S m) = n <= m + +-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and +-- 'enumFromThenTo', are not synthesisable. +instance KnownNat n => Enum (Signed n) where + succ = (+# fromInteger# 1) + pred = (-# fromInteger# 1) + toEnum = fromInteger# . toInteger + fromEnum = fromEnum . toInteger# + enumFrom = enumFrom# + enumFromThen = enumFromThen# + enumFromTo = enumFromTo# + enumFromThenTo = enumFromThenTo# + +{-# NOINLINE enumFrom# #-} +{-# NOINLINE enumFromThen# #-} +{-# NOINLINE enumFromTo# #-} +{-# NOINLINE enumFromThenTo# #-} +enumFrom# :: KnownNat n => Signed n -> [Signed n] +enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n] +enumFromTo# :: KnownNat n => Signed n -> Signed n -> [Signed n] +enumFromThenTo# :: KnownNat n => Signed n -> Signed n -> Signed n -> [Signed n] +enumFrom# x = map toEnum [fromEnum x ..] +enumFromThen# x y = map toEnum [fromEnum x, fromEnum y ..] +enumFromTo# x y = map toEnum [fromEnum x .. fromEnum y] +enumFromThenTo# x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] + + +instance KnownNat n => Bounded (Signed n) where + minBound = minBound# + maxBound = maxBound# + +minBound#,maxBound# :: KnownNat n => Signed n +{-# NOINLINE minBound# #-} +minBound# = let res = S $ negate $ 2 ^ (natVal res - 1) in res +{-# NOINLINE maxBound# #-} +maxBound# = let res = S $ 2 ^ (natVal res - 1) - 1 in res + +-- | Operators do @wrap-around@ on overflow +instance KnownNat n => Num (Signed n) where + (+) = (+#) + (-) = (-#) + (*) = (*#) + negate = negate# + abs = abs# + signum s = if s < 0 then (-1) else + if s > 0 then 1 else 0 + fromInteger = fromInteger# + +(+#), (-#), (*#) :: KnownNat n => Signed n -> Signed n -> Signed n +{-# NOINLINE (+#) #-} +(S a) +# (S b) = fromInteger_INLINE (a + b) + +{-# NOINLINE (-#) #-} +(S a) -# (S b) = fromInteger_INLINE (a - b) + +{-# NOINLINE (*#) #-} +(S a) *# (S b) = fromInteger_INLINE (a * b) + +negate#,abs# :: KnownNat n => Signed n -> Signed n +{-# NOINLINE negate# #-} +negate# (S n) = fromInteger_INLINE (negate n) + +{-# NOINLINE abs# #-} +abs# (S n) = fromInteger_INLINE (abs n) + +{-# NOINLINE fromInteger# #-} +fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat) +fromInteger# = fromInteger_INLINE + +{-# INLINE fromInteger_INLINE #-} +fromInteger_INLINE :: KnownNat n => Integer -> Signed n +fromInteger_INLINE i + | n == 0 = S 0 + | otherwise = res + where + n = natVal res + sz = 2 ^ (n - 1) + res = case divMod i sz of + (s,i') | even s -> S i' + | otherwise -> S (i' - sz) + +instance (KnownNat (1 + Max m n), KnownNat (m + n)) => + ExtendingNum (Signed m) (Signed n) where + type AResult (Signed m) (Signed n) = Signed (1 + Max m n) + plus = plus# + minus = minus# + type MResult (Signed m) (Signed n) = Signed (m + n) + times = times# + +plus#, minus# :: KnownNat (1 + Max m n) => Signed m -> Signed n + -> Signed (1 + Max m n) +{-# NOINLINE plus# #-} +plus# (S a) (S b) = fromInteger_INLINE (a + b) + +{-# NOINLINE minus# #-} +minus# (S a) (S b) = fromInteger_INLINE (a - b) + +{-# NOINLINE times# #-} +times# :: KnownNat (m + n) => Signed m -> Signed n -> Signed (m + n) +times# (S a) (S b) = fromInteger_INLINE (a * b) + +instance KnownNat n => Real (Signed n) where + toRational = toRational . toInteger# + +instance KnownNat n => Integral (Signed n) where + quot = quot# + rem = rem# + div = div# + mod = mod# + quotRem n d = (n `quot#` d,n `rem#` d) + divMod n d = (n `div#` d,n `mod#` d) + toInteger = toInteger# + +quot#,rem#,div#,mod# :: KnownNat n => Signed n -> Signed n -> Signed n +{-# NOINLINE quot# #-} +quot# (S a) (S b) = S (a `quot` b) +{-# NOINLINE rem# #-} +rem# (S a) (S b) = S (a `rem` b) +{-# NOINLINE div# #-} +div# (S a) (S b) = S (a `div` b) +{-# NOINLINE mod# #-} +mod# (S a) (S b) = S (a `mod` b) + +{-# NOINLINE toInteger# #-} +toInteger# :: Signed n -> Integer +toInteger# (S n) = n + +instance KnownNat n => Bits (Signed n) where + (.&.) = and# + (.|.) = or# + xor = xor# + complement = complement# + zeroBits = 0 + bit i = replaceBit 0 i high + setBit v i = replaceBit v i high + clearBit v i = replaceBit v i low + complementBit v i = replaceBit v i (BV.complement# (v ! i)) + testBit v i = v ! i == 1 + bitSizeMaybe v = Just (size# v) + bitSize = size# + isSigned _ = True + shiftL v i = shiftL# v i + shiftR v i = shiftR# v i + rotateL v i = rotateL# v i + rotateR v i = rotateR# v i + popCount = popCount# + +and#,or#,xor# :: KnownNat n => Signed n -> Signed n -> Signed n +{-# NOINLINE and# #-} +and# (S a) (S b) = fromInteger_INLINE (a .&. b) +{-# NOINLINE or# #-} +or# (S a) (S b) = fromInteger_INLINE (a .|. b) +{-# NOINLINE xor# #-} +xor# (S a) (S b) = fromInteger_INLINE (xor a b) + +{-# NOINLINE complement# #-} +complement# :: KnownNat n => Signed n -> Signed n +complement# = unpack# . complement . pack# + +shiftL#,shiftR#,rotateL#,rotateR# :: KnownNat n => Signed n -> Int -> Signed n +{-# NOINLINE shiftL# #-} +shiftL# _ b | b < 0 = error "'shiftL undefined for negative numbers" +shiftL# (S n) b = fromInteger_INLINE (shiftL n b) +{-# NOINLINE shiftR# #-} +shiftR# _ b | b < 0 = error "'shiftR undefined for negative numbers" +shiftR# (S n) b = fromInteger_INLINE (shiftR n b) +{-# NOINLINE rotateL# #-} +rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" +rotateL# s@(S n) b = fromInteger_INLINE (l .|. r) + where + l = shiftL n b' + r = shiftR n b'' .&. mask + mask = 2 ^ b' - 1 + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal s) + +{-# NOINLINE rotateR# #-} +rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" +rotateR# s@(S n) b = fromInteger_INLINE (l .|. r) + where + l = shiftR n b' .&. mask + r = shiftL n b'' + mask = 2 ^ b'' - 1 + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal s) + +{-# NOINLINE popCount# #-} +popCount# :: KnownNat n => Signed n -> Int +popCount# s@(S i) = popCount i' + where + maxI = 2 ^ natVal s + i' = i `mod` maxI + +instance KnownNat n => FiniteBits (Signed n) where + finiteBitSize = size# + +instance Resize Signed where + resize = resize# + extend = resize# + zeroExtend s = unpack# (0 ++# pack s) + signExtend = resize# + truncateB = truncateB# + +{-# NOINLINE resize# #-} +resize# :: (KnownNat n, KnownNat m) => Signed n -> Signed m +resize# s@(S i) | n <= m = extended + | otherwise = truncated + where + n = fromInteger (natVal s) + m = fromInteger (natVal extended) + + extended = fromInteger_INLINE i + + mask = (2 ^ (m - 1)) - 1 + sign = 2 ^ (m - 1) + i' = i .&. mask + truncated = if testBit i (n - 1) + then fromInteger_INLINE (i' .|. sign) + else fromInteger_INLINE i' + +{-# NOINLINE truncateB# #-} +truncateB# :: KnownNat m => Signed (n + m) -> Signed m +truncateB# (S n) = fromInteger_INLINE n + +instance KnownNat n => Default (Signed n) where + def = fromInteger# 0 + +instance KnownNat n => Lift (Signed n) where + lift s@(S i) = sigE [| fromInteger# i |] (decSigned (natVal s)) + +decSigned :: Integer -> TypeQ +decSigned n = appT (conT ''Signed) (litT $ numTyLit n) + +instance (KnownNat n, KnownNat (1 + n), KnownNat (n + n)) => + SaturatingNum (Signed n) where + satPlus SatWrap a b = a +# b + satPlus w a b = case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a .&. msb b of + 1 -> case w of + SatBound -> minBound# + SatSymmetric -> minBoundSym# + _ -> fromInteger# 0 + _ -> case w of + SatZero -> fromInteger# 0 + _ -> maxBound# + where + r = plus# a b + (_,r') = split r + + satMin SatWrap a b = a -# b + satMin w a b = case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a ++# msb b of + 2 -> case w of + SatBound -> minBound# + SatSymmetric -> minBoundSym# + _ -> fromInteger# 0 + _ -> case w of + SatZero -> fromInteger# 0 + _ -> maxBound# + where + r = minus# a b + (_,r') = split r + + + satMult SatWrap a b = a *# b + satMult w a b = case overflow of + 1 -> unpack# rR + _ -> case msb rL of + 0 -> case w of + SatZero -> fromInteger# 0 + _ -> maxBound# + _ -> case w of + SatBound -> minBound# + SatSymmetric -> minBoundSym# + _ -> fromInteger# 0 + where + overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + r = times# a b + (rL,rR) = split r + +minBoundSym# :: KnownNat n => Signed n +minBoundSym# = minBound# +# fromInteger# 1 diff --git a/src/CLaSH/Sized/Internal/Unsigned.hs b/src/CLaSH/Sized/Internal/Unsigned.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Sized/Internal/Unsigned.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module CLaSH.Sized.Internal.Unsigned + ( -- * Datatypes + Unsigned (..) + -- * Accessors + -- ** Length information + , size# + -- * Type classes + -- ** BitConvert + , pack# + , unpack# + -- ** Eq + , eq# + , neq# + -- ** Ord + , lt# + , ge# + , gt# + , le# + -- ** Enum (not synthesisable) + , enumFrom# + , enumFromThen# + , enumFromTo# + , enumFromThenTo# + -- ** Bounded + , minBound# + , maxBound# + -- ** Num + , (+#) + , (-#) + , (*#) + , negate# + , fromInteger# + -- ** ExtendingNum + , plus# + , minus# + , times# + -- ** Integral + , quot# + , rem# + , mod# + , toInteger# + -- ** Bits + , and# + , or# + , xor# + , complement# + , shiftL# + , shiftR# + , rotateL# + , rotateR# + , popCount# + -- ** Resize + , resize# + ) +where + +import Data.Bits (Bits (..), FiniteBits (..)) +import Data.Default (Default (..)) +import Data.Typeable (Typeable) +import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift(..)) + +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), + SaturationMode (..)) +import CLaSH.Class.Resize (Resize (..)) +import CLaSH.Prelude.BitIndex ((!), msb, replaceBit, split) +import CLaSH.Prelude.BitReduction (reduceOr) +import CLaSH.Promoted.Ord (Max) +import CLaSH.Sized.Internal.BitVector (BitVector (..), high, low) +import qualified CLaSH.Sized.Internal.BitVector as BV + +-- | Arbitrary-width unsigned integer represented by @n@ bits +-- +-- Given @n@ bits, an 'Unsigned' @n@ number has a range of: [0 .. 2^@n@-1] +-- +-- __NB__: The 'Num' operators perform @wrap-around@ on overflow. If you want +-- saturation on overflow, check out the 'SaturatingNum' class. +newtype Unsigned (n :: Nat) = + -- | The constructor, 'U', and the field, 'unsafeToBitVector', are not + -- synthesisable. + U { unsafeToBitVector :: Integer } + deriving Typeable + +{-# NOINLINE size# #-} +size# :: KnownNat n => Unsigned n -> Int +size# u = fromInteger (natVal u) + +instance Show (Unsigned n) where + show (U i) = show i + +instance BitPack (Unsigned n) where + type BitSize (Unsigned n) = n + pack = pack# + unpack = unpack# + +{-# NOINLINE pack# #-} +pack# :: Unsigned n -> BitVector n +pack# (U i) = BV i + +{-# NOINLINE unpack# #-} +unpack# :: BitVector n -> Unsigned n +unpack# (BV i) = U i + +instance Eq (Unsigned n) where + (==) = eq# + (/=) = neq# + +{-# NOINLINE eq# #-} +eq# :: Unsigned n -> Unsigned n -> Bool +eq# (U v1) (U v2) = v1 == v2 + +{-# NOINLINE neq# #-} +neq# :: Unsigned n -> Unsigned n -> Bool +neq# (U v1) (U v2) = v1 /= v2 + +instance Ord (Unsigned n) where + (<) = lt# + (>=) = ge# + (>) = gt# + (<=) = le# + +lt#,ge#,gt#,le# :: Unsigned n -> Unsigned n -> Bool +{-# NOINLINE lt# #-} +lt# (U n) (U m) = n < m +{-# NOINLINE ge# #-} +ge# (U n) (U m) = n >= m +{-# NOINLINE gt# #-} +gt# (U n) (U m) = n > m +{-# NOINLINE le# #-} +le# (U n) (U m) = n <= m + +-- | The functions: 'enumFrom', 'enumFromThen', 'enumFromTo', and +-- 'enumFromThenTo', are not synthesisable. +instance KnownNat n => Enum (Unsigned n) where + succ = (+# fromInteger# 1) + pred = (-# fromInteger# 1) + toEnum = fromInteger# . toInteger + fromEnum = fromEnum . toInteger# + enumFrom = enumFrom# + enumFromThen = enumFromThen# + enumFromTo = enumFromTo# + enumFromThenTo = enumFromThenTo# + +{-# NOINLINE enumFrom# #-} +{-# NOINLINE enumFromThen# #-} +{-# NOINLINE enumFromTo# #-} +{-# NOINLINE enumFromThenTo# #-} +enumFrom# :: KnownNat n => Unsigned n -> [Unsigned n] +enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] +enumFromTo# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] +enumFromThenTo# :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n + -> [Unsigned n] +enumFrom# x = map toEnum [fromEnum x ..] +enumFromThen# x y = map toEnum [fromEnum x, fromEnum y ..] +enumFromTo# x y = map toEnum [fromEnum x .. fromEnum y] +enumFromThenTo# x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] + +instance KnownNat n => Bounded (Unsigned n) where + minBound = minBound# + maxBound = maxBound# + +{-# NOINLINE minBound# #-} +minBound# :: KnownNat n => Unsigned n +minBound# = U 0 + +{-# NOINLINE maxBound# #-} +maxBound# :: KnownNat n => Unsigned n +maxBound# = let res = U ((2 ^ natVal res) - 1) in res + +instance KnownNat n => Num (Unsigned n) where + (+) = (+#) + (-) = (-#) + (*) = (*#) + negate = negate# + abs = id + signum bv = resize# (unpack# (reduceOr bv)) + fromInteger = fromInteger# + +(+#),(-#),(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n +{-# NOINLINE (+#) #-} +(+#) (U i) (U j) = fromInteger_INLINE (i + j) + +{-# NOINLINE (-#) #-} +(-#) (U i) (U j) = fromInteger_INLINE (i - j) + +{-# NOINLINE (*#) #-} +(*#) (U i) (U j) = fromInteger_INLINE (i * j) + +{-# NOINLINE negate# #-} +negate# :: KnownNat n => Unsigned n -> Unsigned n +negate# u@(U i) = U (sz - i) + where + sz = 2 ^ natVal u + +{-# NOINLINE fromInteger# #-} +fromInteger# :: KnownNat n => Integer -> Unsigned n +fromInteger# = fromInteger_INLINE + +{-# INLINE fromInteger_INLINE #-} +fromInteger_INLINE :: KnownNat n => Integer -> Unsigned n +fromInteger_INLINE i = let res = U (i `mod` (2 ^ natVal res)) in res + +instance (KnownNat (1 + Max m n), KnownNat (m + n)) => + ExtendingNum (Unsigned m) (Unsigned n) where + type AResult (Unsigned m) (Unsigned n) = Unsigned (1 + Max m n) + plus = plus# + minus = minus# + type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n) + times = times# + +plus#, minus# :: KnownNat (1 + Max m n) => Unsigned m -> Unsigned n + -> Unsigned (1 + Max m n) +{-# NOINLINE plus# #-} +plus# (U a) (U b) = fromInteger_INLINE (a + b) + +{-# NOINLINE minus# #-} +minus# (U a) (U b) = fromInteger_INLINE (a - b) + +{-# NOINLINE times# #-} +times# :: KnownNat (m + n) => Unsigned m -> Unsigned n -> Unsigned (m + n) +times# (U a) (U b) = fromInteger_INLINE (a * b) + +instance KnownNat n => Real (Unsigned n) where + toRational = toRational . toInteger# + +instance KnownNat n => Integral (Unsigned n) where + quot = quot# + rem = rem# + div = quot# + mod = mod# + quotRem n d = (n `quot#` d,n `rem#` d) + divMod n d = (n `quot#` d,n `mod#` d) + toInteger = toInteger# + +quot#,rem#,mod# :: Unsigned n -> Unsigned n -> Unsigned n +{-# NOINLINE quot# #-} +quot# (U i) (U j) = U (i `quot` j) +{-# NOINLINE rem# #-} +rem# (U i) (U j) = U (i `rem` j) +{-# NOINLINE mod# #-} +mod# (U i) (U j) = U (i `mod` j) + +{-# NOINLINE toInteger# #-} +toInteger# :: Unsigned n -> Integer +toInteger# (U i) = i + +instance KnownNat n => Bits (Unsigned n) where + (.&.) = and# + (.|.) = or# + xor = xor# + complement = complement# + zeroBits = 0 + bit i = replaceBit 0 i high + setBit v i = replaceBit v i high + clearBit v i = replaceBit v i low + complementBit v i = replaceBit v i (BV.complement# (v ! i)) + testBit v i = v ! i == high + bitSizeMaybe v = Just (size# v) + bitSize = size# + isSigned _ = False + shiftL v i = shiftL# v i + shiftR v i = shiftR# v i + rotateL v i = rotateL# v i + rotateR v i = rotateR# v i + popCount = popCount# + +{-# NOINLINE and# #-} +and# :: Unsigned n -> Unsigned n -> Unsigned n +and# (U v1) (U v2) = U (v1 .&. v2) + +{-# NOINLINE or# #-} +or# :: Unsigned n -> Unsigned n -> Unsigned n +or# (U v1) (U v2) = U (v1 .|. v2) + +{-# NOINLINE xor# #-} +xor# :: Unsigned n -> Unsigned n -> Unsigned n +xor# (U v1) (U v2) = U (v1 `xor` v2) + +{-# NOINLINE complement# #-} +complement# :: KnownNat n => Unsigned n -> Unsigned n +complement# (U i) = fromInteger_INLINE (complement i) + +shiftL#, shiftR#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int + -> Unsigned n +{-# NOINLINE shiftL# #-} +shiftL# (U v) i + | i < 0 = error + $ "'shiftL undefined for negative number: " ++ show i + | otherwise = fromInteger_INLINE (shiftL v i) + +{-# NOINLINE shiftR# #-} +shiftR# (U v) i + | i < 0 = error + $ "'shiftR undefined for negative number: " ++ show i + | otherwise = fromInteger_INLINE (shiftR v i) + +{-# NOINLINE rotateL# #-} +rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" +rotateL# bv@(U n) b = fromInteger_INLINE (l .|. r) + where + l = shiftL n b' + r = shiftR n b'' + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal bv) + +{-# NOINLINE rotateR# #-} +rotateR# _ b | b < 0 = error "'shiftR undefined for negative numbers" +rotateR# bv@(U n) b = fromInteger_INLINE (l .|. r) + where + l = shiftR n b' + r = shiftL n b'' + + b' = b `mod` sz + b'' = sz - b' + sz = fromInteger (natVal bv) + +{-# NOINLINE popCount# #-} +popCount# :: Unsigned n -> Int +popCount# (U i) = popCount i + +instance KnownNat n => FiniteBits (Unsigned n) where + finiteBitSize = size# + +instance Resize Unsigned where + resize = resize# + zeroExtend = resize# + signExtend = resize# + truncateB = resize# + +{-# NOINLINE resize# #-} +resize# :: KnownNat m => Unsigned n -> Unsigned m +resize# (U i) = fromInteger_INLINE i + +instance KnownNat n => Default (Unsigned n) where + def = minBound# + +instance KnownNat n => Lift (Unsigned n) where + lift u@(U i) = sigE [| fromInteger# i |] (decUnsigned (natVal u)) + +decUnsigned :: Integer -> TypeQ +decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) + +instance (KnownNat n, KnownNat (1 + n), KnownNat (n + n)) => + SaturatingNum (Unsigned n) where + satPlus SatWrap a b = a +# b + satPlus w a b = case msb r of + 0 -> resize# r + _ -> case w of + SatZero -> minBound# + _ -> maxBound# + where + r = plus# a b + + satMin SatWrap a b = a -# b + satMin _ a b = case msb r of + 0 -> resize# r + _ -> minBound# + where + r = minus# a b + + satMult SatWrap a b = a *# b + satMult w a b = case rL of + 0 -> unpack# rR + _ -> case w of + SatZero -> minBound# + _ -> maxBound# + where + r = times# a b + (rL,rR) = split r diff --git a/src/CLaSH/Sized/Signed.hs b/src/CLaSH/Sized/Signed.hs --- a/src/CLaSH/Sized/Signed.hs +++ b/src/CLaSH/Sized/Signed.hs @@ -1,338 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - module CLaSH.Sized.Signed ( Signed - , resizeS_wrap ) where -import Data.Bits -import Data.Default -import Data.Typeable -import Language.Haskell.TH -import Language.Haskell.TH.Syntax(Lift(..)) -import GHC.TypeLits - -import CLaSH.Bit -import CLaSH.Class.BitVector -import CLaSH.Class.Num -import CLaSH.Promoted.Ord -import CLaSH.Sized.Vector - --- | Arbitrary-width signed integer represented by @n@ bits, including the sign bit. --- --- Uses standard 2-complements representation. Meaning that, given @n@ bits, --- a 'Signed' @n@ number has a range of: [-(2^(@n@-1)) .. 2^(@n@-1)-1] --- --- NB: The 'Num' operators perform @wrap-around@ on overflow. If you want saturation --- on overflow, check out the 'CLaSH.Sized.Fixed.satN2' function in "CLaSH.Sized.Fixed". -newtype Signed (n :: Nat) = S Integer - deriving Typeable - -instance Eq (Signed n) where - (==) = eqS - -{-# NOINLINE eqS #-} -eqS :: (Signed n) -> (Signed n) -> Bool -(S n) `eqS` (S m) = n == m - -instance Ord (Signed n) where - (<) = ltS - (>=) = geS - (>) = gtS - (<=) = leS - -ltS,geS,gtS,leS :: Signed n -> Signed n -> Bool -{-# NOINLINE ltS #-} -ltS (S n) (S m) = n < m -{-# NOINLINE geS #-} -geS (S n) (S m) = n >= m -{-# NOINLINE gtS #-} -gtS (S n) (S m) = n > m -{-# NOINLINE leS #-} -leS (S n) (S m) = n <= m - -instance KnownNat n => Enum (Signed n) where - succ = plusS (fromIntegerS 1) - pred = minS (fromIntegerS 1) - toEnum = fromIntegerS . toInteger - fromEnum = fromEnum . toIntegerS - enumFrom = enumFromS - enumFromThen = enumFromThenS - enumFromTo = enumFromToS - enumFromThenTo = enumFromThenToS - -{-# NOINLINE enumFromS #-} -{-# NOINLINE enumFromThenS #-} -{-# NOINLINE enumFromToS #-} -{-# NOINLINE enumFromThenToS #-} -enumFromS :: KnownNat n => Signed n -> [Signed n] -enumFromThenS :: KnownNat n => Signed n -> Signed n -> [Signed n] -enumFromToS :: KnownNat n => Signed n -> Signed n -> [Signed n] -enumFromThenToS :: KnownNat n => Signed n -> Signed n -> Signed n -> [Signed n] -enumFromS x = map toEnum [fromEnum x ..] -enumFromThenS x y = map toEnum [fromEnum x, fromEnum y ..] -enumFromToS x y = map toEnum [fromEnum x .. fromEnum y] -enumFromThenToS x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] - - -instance KnownNat n => Bounded (Signed n) where - minBound = minBoundS - maxBound = maxBoundS - -minBoundS,maxBoundS :: KnownNat n => Signed n -{-# NOINLINE minBoundS #-} -minBoundS = let res = S $ negate $ 2 ^ (natVal res - 1) in res -{-# NOINLINE maxBoundS #-} -maxBoundS = let res = S $ 2 ^ (natVal res - 1) - 1 in res - --- | Operators do @wrap-around@ on overflow -instance KnownNat n => Num (Signed n) where - (+) = plusS - (-) = minS - (*) = timesS - negate = negateS - abs = absS - signum = signumS - fromInteger = fromIntegerS - -plusS,minS,timesS :: KnownNat n => Signed n -> Signed n -> Signed n -{-# NOINLINE plusS #-} -plusS (S a) (S b) = fromIntegerS_inlineable (a + b) - -{-# NOINLINE minS #-} -minS (S a) (S b) = fromIntegerS_inlineable (a - b) - -{-# NOINLINE timesS #-} -timesS (S a) (S b) = fromIntegerS_inlineable (a * b) - -negateS,absS,signumS :: KnownNat n => Signed n -> Signed n -{-# NOINLINE negateS #-} -negateS (S n) = fromIntegerS_inlineable (0 - n) - -{-# NOINLINE absS #-} -absS (S n) = fromIntegerS_inlineable (abs n) - -{-# NOINLINE signumS #-} -signumS (S n) = fromIntegerS_inlineable (signum n) - -fromIntegerS,fromIntegerS_inlineable :: KnownNat n => Integer -> Signed (n :: Nat) -{-# NOINLINE fromIntegerS #-} -fromIntegerS = fromIntegerS_inlineable -{-# INLINABLE fromIntegerS_inlineable #-} -fromIntegerS_inlineable i - | nS == 0 = S 0 - | otherwise = res - where - nS = natVal res - sz = 2 ^ (nS - 1) - res = case divMod i sz of - (s,i') | even s -> S i' - | otherwise -> S (i' - sz) - -instance KnownNat (Max m n) => Add (Signed m) (Signed n) where - type AResult (Signed m) (Signed n) = Signed (Max m n) - plus = plusS2 - minus = minusS2 - -plusS2, minusS2 :: KnownNat (Max m n) => Signed m -> Signed n -> Signed (Max m n) -{-# NOINLINE plusS2 #-} -plusS2 (S a) (S b) = fromIntegerS_inlineable (a + b) - -{-# NOINLINE minusS2 #-} -minusS2 (S a) (S b) = fromIntegerS_inlineable (a - b) - -instance KnownNat (m + n) => Mult (Signed m) (Signed n) where - type MResult (Signed m) (Signed n) = Signed (m + n) - mult = multS2 - -{-# NOINLINE multS2 #-} -multS2 :: KnownNat (m + n) => Signed m -> Signed n -> Signed (m + n) -multS2 (S a) (S b) = fromIntegerS_inlineable (a * b) - -instance KnownNat n => Real (Signed n) where - toRational = toRational . toIntegerS - -instance KnownNat n => Integral (Signed n) where - quot = quotS - rem = remS - div = divS - mod = modS - quotRem = quotRemS - divMod = divModS - toInteger = toIntegerS - -quotS,remS,divS,modS :: KnownNat n => Signed n -> Signed n -> Signed n -{-# NOINLINE quotS #-} -quotS = (fst.) . quotRemS_inlineable -{-# NOINLINE remS #-} -remS = (snd.) . quotRemS_inlineable -{-# NOINLINE divS #-} -divS = (fst.) . divModS_inlineable -{-# NOINLINE modS #-} -modS = (snd.) . divModS_inlineable - -quotRemS,divModS :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n) -quotRemS n d = (n `quotS` d,n `remS` d) -divModS n d = (n `divS` d,n `modS` d) - -quotRemS_inlineable,divModS_inlineable :: KnownNat n => Signed n -> Signed n -> (Signed n, Signed n) -{-# INLINEABLE quotRemS_inlineable #-} -(S a) `quotRemS_inlineable` (S b) = let (a',b') = a `quotRem` b - in (fromIntegerS_inlineable a', fromIntegerS_inlineable b') -{-# INLINEABLE divModS_inlineable #-} -(S a) `divModS_inlineable` (S b) = let (a',b') = a `divMod` b - in (fromIntegerS_inlineable a', fromIntegerS_inlineable b') - -{-# NOINLINE toIntegerS #-} -toIntegerS :: Signed n -> Integer -toIntegerS (S n) = n - -instance KnownNat n => Bits (Signed n) where - (.&.) = andS - (.|.) = orS - xor = xorS - complement = complementS - bit = bitS - testBit = testBitS - bitSizeMaybe = Just . finiteBitSizeS - isSigned = const True - shiftL = shiftLS - shiftR = shiftRS - rotateL = rotateLS - rotateR = rotateRS - popCount = popCountS - -andS,orS,xorS :: KnownNat n => Signed n -> Signed n -> Signed n -{-# NOINLINE andS #-} -(S a) `andS` (S b) = fromIntegerS_inlineable (a .&. b) -{-# NOINLINE orS #-} -(S a) `orS` (S b) = fromIntegerS_inlineable (a .|. b) -{-# NOINLINE xorS #-} -(S a) `xorS` (S b) = fromIntegerS_inlineable (xor a b) - -{-# NOINLINE complementS #-} -complementS :: KnownNat n => Signed n -> Signed n -complementS = fromBitVector . vmap complement . toBitVector - -{-# NOINLINE bitS #-} -bitS :: KnownNat n => Int -> Signed n -bitS i = res - where - sz = finiteBitSizeS res - res | sz > i = fromIntegerS_inlineable (bit i) - | otherwise = error $ concat [ "bit: " - , "Setting out-of-range bit position, size: " - , show sz - , ", position: " - , show i - ] - -{-# NOINLINE testBitS #-} -testBitS :: KnownNat n => Signed n -> Int -> Bool -testBitS s@(S n) i - | sz > i = testBit n i - | otherwise = error $ concat [ "testBit: " - , "Setting out-of-range bit position, size: " - , show sz - , ", position: " - , show i - ] - where - sz = finiteBitSizeS s - -shiftLS,shiftRS,rotateLS,rotateRS :: KnownNat n => Signed n -> Int -> Signed n -{-# NOINLINE shiftLS #-} -shiftLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers" -shiftLS (S n) b = fromIntegerS_inlineable (shiftL n b) -{-# NOINLINE shiftRS #-} -shiftRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers" -shiftRS (S n) b = fromIntegerS_inlineable (shiftR n b) -{-# NOINLINE rotateLS #-} -rotateLS _ b | b < 0 = error "'shiftL'{Signed} undefined for negative numbers" -rotateLS n b = let b' = b `mod` finiteBitSizeS n - in shiftL n b' .|. shiftR n (finiteBitSizeS n - b') -{-# NOINLINE rotateRS #-} -rotateRS _ b | b < 0 = error "'shiftR'{Signed} undefined for negative numbers" -rotateRS n b = let b' = b `mod` finiteBitSizeS n - in shiftR n b' .|. shiftL n (finiteBitSizeS n - b') - -{-# NOINLINE popCountS #-} -popCountS :: Signed n -> Int -popCountS (S n) = popCount n - -instance KnownNat n => FiniteBits (Signed n) where - finiteBitSize = finiteBitSizeS - -{-# NOINLINE finiteBitSizeS #-} -finiteBitSizeS :: KnownNat n => Signed n -> Int -finiteBitSizeS = fromInteger . natVal - -instance Show (Signed n) where - show (S n) = show n - -instance KnownNat n => Default (Signed n) where - def = fromIntegerS 0 - -instance KnownNat n => Lift (Signed n) where - lift s@(S i) = sigE [| fromIntegerS i |] (decSigned (natVal s)) - -decSigned :: Integer -> TypeQ -decSigned n = appT (conT ''Signed) (litT $ numTyLit n) - -instance BitVector (Signed n) where - type BitSize (Signed n) = n - toBV = toBitVector - fromBV = fromBitVector - -{-# NOINLINE toBitVector #-} -toBitVector :: KnownNat n => Signed n -> Vec n Bit -toBitVector (S m) = vreverse $ vmap (\x -> if odd x then H else L) $ viterateI (`div` 2) m - -{-# NOINLINE fromBitVector #-} -fromBitVector :: KnownNat n => Vec n Bit -> Signed n -fromBitVector = fromBitList . reverse . toList - -{-# INLINABLE fromBitList #-} -fromBitList :: KnownNat n => [Bit] -> Signed n -fromBitList l = fromIntegerS_inlineable - $ sum [ n - | (n,b) <- zip (iterate (*2) 1) l - , b == H - ] - -{-# NOINLINE resizeS #-} -resizeS :: (KnownNat n, KnownNat m) => Signed n -> Signed m -resizeS s@(S n) | n' <= m' = extend - | otherwise = trunc - where - n' = fromInteger (natVal s) - m' = fromInteger (natVal extend) - extend = fromIntegerS_inlineable n - trunc = case toList (toBitVector s) of - (x:xs) -> fromBitList $ reverse $ x : (drop (n' - m') xs) - _ -> error "resizeS impossible case: empty list" - -{-# NOINLINE resizeS_wrap #-} --- | A resize operation that is sign-preserving on extension, but wraps on truncation. --- --- Increasing the size of the number replicates the sign bit to the left. --- Truncating a number of length N to a length L just removes the leftmost N-L bits. -resizeS_wrap :: KnownNat m => Signed n -> Signed m -resizeS_wrap (S n) = fromIntegerS_inlineable n - --- | A sign-preserving resize operation --- --- Increasing the size of the number replicates the sign bit to the left. --- Truncating a number to length L keeps the sign bit and the rightmost L-1 bits. -instance Resize Signed where - resize = resizeS +import CLaSH.Sized.Internal.Signed diff --git a/src/CLaSH/Sized/Unsigned.hs b/src/CLaSH/Sized/Unsigned.hs --- a/src/CLaSH/Sized/Unsigned.hs +++ b/src/CLaSH/Sized/Unsigned.hs @@ -1,300 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-missing-methods #-} - module CLaSH.Sized.Unsigned - ( Unsigned - ) + (Unsigned) where -import Data.Bits -import Data.Default -import Data.Typeable -import Language.Haskell.TH -import Language.Haskell.TH.Syntax(Lift(..)) -import GHC.TypeLits - -import CLaSH.Bit -import CLaSH.Class.BitVector -import CLaSH.Class.Num -import CLaSH.Promoted.Ord -import CLaSH.Sized.Vector - --- | Arbitrary-width unsigned integer represented by @n@ bits --- --- Given @n@ bits, an 'Unsigned' @n@ number has a range of: [0 .. 2^@n@-1] --- --- NB: The 'Num' operators perform @wrap-around@ on overflow. If you want saturation --- on overflow, check out the 'CLaSH.Sized.Fixed.satN2' function in "CLaSH.Sized.Fixed". -newtype Unsigned (n :: Nat) = U Integer - deriving Typeable - -instance Eq (Unsigned n) where - (==) = eqU - -{-# NOINLINE eqU #-} -eqU :: (Unsigned n) -> (Unsigned n) -> Bool -(U n) `eqU` (U m) = n == m - -instance Ord (Unsigned n) where - (<) = ltU - (>=) = geU - (>) = gtU - (<=) = leU - -ltU,geU,gtU,leU :: Unsigned n -> Unsigned n -> Bool -{-# NOINLINE ltU #-} -ltU (U n) (U m) = n < m -{-# NOINLINE geU #-} -geU (U n) (U m) = n >= m -{-# NOINLINE gtU #-} -gtU (U n) (U m) = n > m -{-# NOINLINE leU #-} -leU (U n) (U m) = n <= m - -instance KnownNat n => Enum (Unsigned n) where - succ = plusU (fromIntegerU 1) - pred = minU (fromIntegerU 1) - toEnum = fromIntegerU . toInteger - fromEnum = fromEnum . toIntegerU - enumFrom = enumFromU - enumFromThen = enumFromThenU - enumFromTo = enumFromToU - enumFromThenTo = enumFromThenToU - -{-# NOINLINE enumFromU #-} -{-# NOINLINE enumFromThenU #-} -{-# NOINLINE enumFromToU #-} -{-# NOINLINE enumFromThenToU #-} -enumFromU :: KnownNat n => Unsigned n -> [Unsigned n] -enumFromThenU :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] -enumFromToU :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] -enumFromThenToU :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n] -enumFromU x = map toEnum [fromEnum x ..] -enumFromThenU x y = map toEnum [fromEnum x, fromEnum y ..] -enumFromToU x y = map toEnum [fromEnum x .. fromEnum y] -enumFromThenToU x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] - -instance KnownNat n => Bounded (Unsigned n) where - minBound = fromIntegerU 0 - maxBound = maxBoundU - -{-# NOINLINE maxBoundU #-} -maxBoundU :: KnownNat n => Unsigned n -maxBoundU = let res = U ((2 ^ natVal res) - 1) in res - --- | Operators do @wrap-around@ on overflow -instance KnownNat n => Num (Unsigned n) where - (+) = plusU - (-) = minU - (*) = timesU - negate = id - abs = id - signum = signumU - fromInteger = fromIntegerU - -plusU,minU,timesU :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -{-# NOINLINE plusU #-} -plusU (U a) (U b) = fromIntegerU_inlineable $ a + b - -{-# NOINLINE minU #-} -minU (U a) (U b) = fromIntegerU_inlineable $ a - b - -{-# NOINLINE timesU #-} -timesU (U a) (U b) = fromIntegerU_inlineable $ a * b - -{-# NOINLINE signumU #-} -signumU :: Unsigned n -> Unsigned n -signumU (U 0) = (U 0) -signumU (U _) = (U 1) - -fromIntegerU,fromIntegerU_inlineable :: KnownNat n => Integer -> Unsigned n -{-# NOINLINE fromIntegerU #-} -fromIntegerU = fromIntegerU_inlineable -{-# INLINABLE fromIntegerU_inlineable #-} -fromIntegerU_inlineable i = let res = U (i `mod` (2 ^ natVal res)) in res - -instance KnownNat (Max m n) => Add (Unsigned m) (Unsigned n) where - type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n) - plus = plusU2 - minus = minusU2 - -plusU2, minusU2 :: KnownNat (Max m n) => Unsigned m -> Unsigned n -> Unsigned (Max m n) -{-# NOINLINE plusU2 #-} -plusU2 (U a) (U b) = fromIntegerU_inlineable (a + b) - -{-# NOINLINE minusU2 #-} -minusU2 (U a) (U b) = fromIntegerU_inlineable (a - b) - -instance KnownNat (m + n) => Mult (Unsigned m) (Unsigned n) where - type MResult (Unsigned m) (Unsigned n) = Unsigned (m + n) - mult = multU2 - -{-# NOINLINE multU2 #-} -multU2 :: KnownNat (m + n) => Unsigned m -> Unsigned n -> Unsigned (m + n) -multU2 (U a) (U b) = fromIntegerU_inlineable (a * b) - -instance KnownNat n => Real (Unsigned n) where - toRational = toRational . toIntegerU - -instance KnownNat n => Integral (Unsigned n) where - quot = quotU - rem = remU - div = quotU - mod = modU - quotRem = quotRemU - divMod = divModU - toInteger = toIntegerU - -quotU,remU,modU :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -{-# NOINLINE quotU #-} -quotU = (fst.) . quotRemU_inlineable -{-# NOINLINE remU #-} -remU = (snd.) . quotRemU_inlineable -{-# NOINLINE modU #-} -(U a) `modU` (U b) = fromIntegerU_inlineable (a `mod` b) - -quotRemU,divModU :: KnownNat n => Unsigned n -> Unsigned n -> (Unsigned n, Unsigned n) -quotRemU n d = (n `quotU` d,n `remU` d) -divModU n d = (n `quotU` d,n `modU` d) - -{-# INLINEABLE quotRemU_inlineable #-} -quotRemU_inlineable :: KnownNat n => Unsigned n -> Unsigned n -> (Unsigned n, Unsigned n) -(U a) `quotRemU_inlineable` (U b) = let (a',b') = a `quotRem` b - in (fromIntegerU_inlineable a', fromIntegerU_inlineable b') - -{-# NOINLINE toIntegerU #-} -toIntegerU :: Unsigned n -> Integer -toIntegerU (U n) = n - -instance KnownNat n => Bits (Unsigned n) where - (.&.) = andU - (.|.) = orU - xor = xorU - complement = complementU - bit = bitU - testBit = testBitU - bitSizeMaybe = Just . finiteBitSizeU - isSigned = const False - shiftL = shiftLU - shiftR = shiftRU - rotateL = rotateLU - rotateR = rotateRU - popCount = popCountU - -andU,orU,xorU :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n -{-# NOINLINE andU #-} -(U a) `andU` (U b) = fromIntegerU_inlineable (a .&. b) -{-# NOINLINE orU #-} -(U a) `orU` (U b) = fromIntegerU_inlineable (a .|. b) -{-# NOINLINE xorU #-} -(U a) `xorU` (U b) = fromIntegerU_inlineable (xor a b) - -{-# NOINLINE complementU #-} -complementU :: KnownNat n => Unsigned n -> Unsigned n -complementU = fromBitVector . vmap complement . toBitVector - -{-# NOINLINE bitU #-} -bitU :: KnownNat n => Int -> Unsigned n -bitU i = res - where - sz = finiteBitSizeU res - res | sz > i = fromIntegerU_inlineable (bit i) - | otherwise = error $ concat [ "bit: " - , "Setting out-of-range bit position, size: " - , show sz - , ", position: " - , show i - ] - -{-# NOINLINE testBitU #-} -testBitU :: KnownNat n => Unsigned n -> Int -> Bool -testBitU s@(U n) i - | sz > i = testBit n i - | otherwise = error $ concat [ "testBit: " - , "Setting out-of-range bit position, size: " - , show sz - , ", position: " - , show i - ] - where - sz = finiteBitSizeU s - -shiftLU,shiftRU,rotateLU,rotateRU :: KnownNat n => Unsigned n -> Int -> Unsigned n -{-# NOINLINE shiftLU #-} -shiftLU _ b | b < 0 = error "'shiftL'{Unsigned} undefined for negative numbers" -shiftLU (U n) b = fromIntegerU_inlineable (shiftL n b) -{-# NOINLINE shiftRU #-} -shiftRU _ b | b < 0 = error "'shiftR'{Unsigned} undefined for negative numbers" -shiftRU (U n) b = fromIntegerU_inlineable (shiftR n b) -{-# NOINLINE rotateLU #-} -rotateLU _ b | b < 0 = error "'shiftL'{Unsigned} undefined for negative numbers" -rotateLU n b = let b' = b `mod` finiteBitSizeU n - in shiftL n b' .|. shiftR n (finiteBitSizeU n - b') -{-# NOINLINE rotateRU #-} -rotateRU _ b | b < 0 = error "'shiftR'{Unsigned} undefined for negative numbers" -rotateRU n b = let b' = b `mod` finiteBitSizeU n - in shiftR n b' .|. shiftL n (finiteBitSizeU n - b') - -{-# NOINLINE popCountU #-} -popCountU :: Unsigned n -> Int -popCountU (U n) = popCount n - -instance KnownNat n => FiniteBits (Unsigned n) where - finiteBitSize = finiteBitSizeU - -{-# NOINLINE finiteBitSizeU #-} -finiteBitSizeU :: KnownNat n => Unsigned n -> Int -finiteBitSizeU u = fromInteger (natVal u) - -instance KnownNat n => Lift (Unsigned n) where - lift u@(U i) = sigE [| fromIntegerU i |] (decUnsigned (natVal u)) - -decUnsigned :: Integer -> TypeQ -decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) - -instance Show (Unsigned n) where - show (U n) = show n - -instance KnownNat n => Default (Unsigned n) where - def = fromIntegerU 0 - -instance BitVector (Unsigned n) where - type BitSize (Unsigned n) = n - toBV = toBitVector - fromBV = fromBitVector - -{-# NOINLINE toBitVector #-} -toBitVector :: KnownNat n => Unsigned n -> Vec n Bit -toBitVector (U m) = vreverse $ vmap (\x -> if odd x then H else L) $ viterateI (`div` 2) m - -{-# NOINLINE fromBitVector #-} -fromBitVector :: KnownNat n => Vec n Bit -> Unsigned n -fromBitVector = fromBitList . reverse . toList - -{-# INLINABLE fromBitList #-} -fromBitList :: KnownNat n => [Bit] -> Unsigned n -fromBitList l = fromIntegerU_inlineable - $ sum [ n - | (n,b) <- zip (iterate (*2) 1) l - , b == H - ] - -{-# NOINLINE resizeU #-} -resizeU :: KnownNat m => Unsigned n -> Unsigned m -resizeU (U n) = fromIntegerU_inlineable n - --- | A resize operation that zero-extends on extension, and wraps on truncation. --- --- Increasing the size of the number extends with zeros to the left. --- Truncating a number of length N to a length L just removes the left --- (most significant) N-L bits. -instance Resize Unsigned where - resize = resizeU +import CLaSH.Sized.Internal.Unsigned diff --git a/src/CLaSH/Sized/Vector.hs b/src/CLaSH/Sized/Vector.hs --- a/src/CLaSH/Sized/Vector.hs +++ b/src/CLaSH/Sized/Vector.hs @@ -2,727 +2,964 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} - -module CLaSH.Sized.Vector - ( -- * 'Vec'tor constructors - Vec(..), (<:) - -- * Standard 'Vec'tor functions - -- ** Extracting sub-'Vec'tors - , vhead, vtail, vlast, vinit - , vtake, vtakeI, vdrop, vdropI, vexact, vselect, vselectI - -- ** Combining 'Vec'tors - , (+>>), (<<+), (<++>), vconcat, vzip, vunzip - -- ** Splitting 'Vec'tors - , vsplit, vsplitI, vunconcat, vunconcatI, vmerge - -- ** Applying functions to 'Vec'tor elements - , vmap, vzipWith - , vfoldr, vfoldl, vfoldr1, vfoldl1 - , vscanl, vscanr, vscanl1, vscanr1 - , vmapAccumL, vmapAccumR - -- ** Indexing 'Vec'tors - , (!), vreplace, maxIndex, vlength - -- ** Generating 'Vec'tors - , vcopy, vcopyI, viterate, viterateI, vgenerate, vgenerateI - -- ** Misc - , vreverse, toList, v, lazyV, asNatProxy - -- * Alternative 'Vec'tor functions - , vhead' - ) -where - -import Control.Applicative --- import Data.Traversable -import Data.Default -import Data.Foldable hiding (toList) -import Data.Proxy -import GHC.TypeLits -import Language.Haskell.TH (ExpQ) -import Language.Haskell.TH.Syntax (Lift(..)) -import Unsafe.Coerce (unsafeCoerce) - -import CLaSH.Promoted.Nat - --- | Fixed size vectors --- --- * Lists with their length encoded in their type --- * 'Vec'tor elements have a DESCENDING subscript starting from 'maxIndex' --- ('vlength' - 1) and ending at 0 --- --- >>> (3:>4:>5:>Nil) --- <3,4,5> --- >>> :t (3:>4:>5:>Nil) --- (3:>4:>5:>Nil) :: Num a => Vec 3 a -data Vec :: Nat -> * -> * where - Nil :: Vec 0 a - (:>) :: a -> Vec n a -> Vec (n + 1) a - -infixr 5 :> - -instance Show a => Show (Vec n a) where - show vs = "<" ++ punc vs ++ ">" - where - punc :: Show a => Vec m a -> String - punc Nil = "" - punc (x :> Nil) = show x - punc (x :> xs) = show x ++ "," ++ punc xs - -instance Eq a => Eq (Vec n a) where - v1 == v2 = vfoldr (&&) True (vzipWith (==) v1 v2) - -instance KnownNat n => Applicative (Vec n) where - pure = vcopyI - (<*>) = vzipWith ($) - --- instance Traversable (Vec n) where --- traverse _ Nil = pure Nil --- traverse f (x :> xs) = (:>) <$> f x <*> traverse f xs - -instance Foldable (Vec n) where - foldr = vfoldr - -instance Functor (Vec n) where - fmap = vmap - -instance (Default a, KnownNat n) => Default (Vec n a) where - def = vcopyI def - -{-# NOINLINE vhead #-} --- | Extract the first element of a vector --- --- >>> vhead (1:>2:>3:>Nil) --- 1 --- >>> vhead Nil --- --- Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- In the first argument of ‘vhead’, namely ‘Nil’ --- In the expression: vhead Nil -vhead :: Vec (n + 1) a -> a -vhead (x :> _) = x - -{-# NOINLINE vtail #-} --- | Extract the elements after the head of a vector --- --- >>> vtail (1:>2:>3:>Nil) --- <2,3> --- >>> vtail Nil --- --- Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- In the first argument of ‘vtail’, namely ‘Nil’ --- In the expression: vtail Nil -vtail :: Vec (n + 1) a -> Vec n a -vtail (_ :> xs) = unsafeCoerce xs - -{-# NOINLINE vlast #-} --- | Extract the last element of a vector --- --- >>> vlast (1:>2:>3:>Nil) --- 3 --- >>> vlast Nil --- --- Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- In the first argument of ‘vlast’, namely ‘Nil’ --- In the expression: vlast Nil -vlast :: Vec (n + 1) a -> a -vlast (x :> Nil) = x -vlast (_ :> y :> ys) = vlast (y :> ys) - -{-# NOINLINE vinit #-} --- | Extract all the elements of a vector except the last element --- --- >>> vinit (1:>2:>3:>Nil) --- <1,2> --- >>> vinit Nil --- --- Couldn't match type ‘1’ with ‘0’ --- Expected type: Vec (0 + 1) a --- Actual type: Vec 0 a --- In the first argument of ‘vinit’, namely ‘Nil’ --- In the expression: vinit Nil -vinit :: Vec (n + 1) a -> Vec n a -vinit (_ :> Nil) = unsafeCoerce Nil -vinit (x :> y :> ys) = unsafeCoerce (x :> vinit (y :> ys)) - -{-# NOINLINE shiftIntoL #-} --- | Add an element to the head of the vector, and extract all elements of the --- resulting vector except the last element -shiftIntoL :: a -> Vec n a -> Vec n a -shiftIntoL _ Nil = Nil -shiftIntoL s (x :> xs) = s :> (vinit (x:>xs)) - -infixr 4 +>> -{-# INLINEABLE (+>>) #-} --- | Add an element to the head of the vector, and extract all elements of the --- resulting vector except the last element --- --- >>> 1 +>> (3:>4:>5:>Nil) --- <1,3,4> --- >>> 1 +>> Nil --- <> -(+>>) :: a -> Vec n a -> Vec n a -s +>> xs = shiftIntoL s xs - -{-# NOINLINE snoc #-} --- | Add an element to the tail of the vector -snoc :: a -> Vec n a -> Vec (n + 1) a -snoc s Nil = s :> Nil -snoc s (x :> xs) = x :> (snoc s xs) - -infixl 5 <: -{-# INLINEABLE (<:) #-} --- | Add an element to the tail of the vector --- --- >>> (3:>4:>5:>Nil) <: 1 --- <3,4,5,1> --- >>> :t (3:>4:>5:>Nil) <: 1 --- (3:>4:>5:>Nil) <: 1 :: Num a => Vec 4 a -(<:) :: Vec n a -> a -> Vec (n + 1) a -xs <: s = snoc s xs - -{-# NOINLINE shiftIntoR #-} --- | Add an element to the tail of the vector, and extract all elements of the --- resulting vector except the first element -shiftIntoR :: a -> Vec n a -> Vec n a -shiftIntoR _ Nil = Nil -shiftIntoR s (x:>xs) = snoc s (vtail (x:>xs)) - -infixl 4 <<+ -{-# INLINE (<<+) #-} --- | Add an element to the tail of the vector, and extract all elements of the --- resulting vector except the first element --- --- >>> (3:>4:>5:>Nil) <<+ 1 --- <4,5,1> --- >>> Nil <<+ 1 --- <> -(<<+) :: Vec n a -> a -> Vec n a -xs <<+ s = shiftIntoR s xs - -{-# NOINLINE vappend #-} --- | Append two vectors -vappend :: Vec n a -> Vec m a -> Vec (n + m) a -vappend Nil ys = ys -vappend (x :> xs) ys = unsafeCoerce (x :> (vappend xs ys)) - -infixr 5 <++> -{-# INLINE (<++>) #-} --- | Append two vectors --- --- >>> (1:>2:>3:>Nil) <++> (7:>8:>Nil) --- <1,2,3,7,8> -(<++>) :: Vec n a -> Vec m a -> Vec (n + m) a -xs <++> ys = vappend xs ys - -{-# NOINLINE vsplit #-} --- | Split a vector into two vectors at the given point --- --- >>> vsplit (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>, <7,8>) --- >>> vsplit d3 (1:>2:>3:>7:>8:>Nil) --- (<1,2,3>, <7,8>) -vsplit :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -vsplit n xs = vsplitU (toUNat n) xs - -vsplitU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) -vsplitU UZero ys = (Nil,ys) -vsplitU (USucc s) (y :> ys) = let (as,bs) = vsplitU s (unsafeCoerce ys) - in (y :> as, bs) - -{-# INLINEABLE vsplitI #-} --- | Split a vector into two vectors where the length of the two is determined --- by the context --- --- >>> vsplitI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int) --- (<1,2>,<3,7,8>) -vsplitI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a) -vsplitI = withSNat vsplit - -{-# NOINLINE vconcat #-} --- | Concatenate a vector of vectors --- --- >>> vconcat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil) --- <1,2,3,4,5,6,7,8,9,10,11,12> -vconcat :: Vec n (Vec m a) -> Vec (n * m) a -vconcat Nil = Nil -vconcat (x :> xs) = unsafeCoerce (vappend x (vconcat xs)) - -{-# NOINLINE vunconcat #-} --- | Split a vector of (n * m) elements into a vector of vectors with length m, --- where m is given --- --- >>> vunconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) --- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>> -vunconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a) -vunconcat n xs = vunconcatU (withSNat toUNat) (toUNat n) xs - -vunconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) -vunconcatU UZero _ _ = Nil -vunconcatU (USucc n') m ys = let (as,bs) = vsplitU m (unsafeCoerce ys) - in as :> vunconcatU n' m bs - -{-# INLINEABLE vunconcatI #-} --- | Split a vector of (n * m) elements into a vector of vectors with length m, --- where m is determined by the context --- --- >>> vunconcatI (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) :: Vec 2 (Vec 6 Int) --- <<1,2,3,4,5,6>,<7,8,9,10,11,12>> -vunconcatI :: (KnownNat n, KnownNat m) => Vec (n * m) a -> Vec n (Vec m a) -vunconcatI = withSNat vunconcat - -{-# NOINLINE vmerge #-} --- | Merge two vectors, alternating their elements, i.e., --- --- >>> vmerge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil) --- <1,5,2,6,3,7,4,8> -vmerge :: Vec n a -> Vec n a -> Vec (n + n) a -vmerge Nil Nil = Nil -vmerge (x :> xs) (y :> ys) = unsafeCoerce (x :> y :> (vmerge xs (unsafeCoerce ys))) - -{-# NOINLINE vreverse #-} --- | Returns the elements in a vector in reverse order --- --- >>> vreverse (1:>2:>3:>4:>Nil) --- <4,3,2,1> -vreverse :: Vec n a -> Vec n a -vreverse Nil = Nil -vreverse (x :> xs) = vreverse xs <: x - -{-# NOINLINE vmap #-} --- | 'vmap' @f xs@ is the vector obtained by applying @f@ to each element --- of @xs@, i.e., --- --- > vmap f (xn :> ... :> x2 :> x1 :> Nil) == (f xn :> ... :> f x2 :> f x1 :> Nil) -vmap :: (a -> b) -> Vec n a -> Vec n b -vmap _ Nil = Nil -vmap f (x :> xs) = f x :> vmap f xs - -{-# NOINLINE vzipWith #-} --- | 'vzipWith' generalises 'vzip' by zipping with the function given --- as the first argument, instead of a tupling function. --- For example, @'vzipWith' (+)@ is applied to two vectors to produce the --- vector of corresponding sums. --- --- > vzipWith f (xn :> ... :> x2 :> x1 :> Nil) (yn :> ... :> y2 :> y1 :> Nil) == (f xn yn :> ... :> f x2 y2 :> f x1 y1 :> Nil) -vzipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c -vzipWith _ Nil Nil = Nil -vzipWith f (x :> xs) (y :> ys) = f x y :> (vzipWith f xs (unsafeCoerce ys)) - -{-# NOINLINE vfoldr #-} --- | 'vfoldr', applied to a binary operator, a starting value (typically --- the right-identity of the operator), and a vector, reduces the vector --- using the binary operator, from right to left: --- --- > vfoldr f z (xn :> ... :> x2 :> x1 :> Nil) == xn `f` (... (x2 `f` (x1 `f` z))...) --- > vfoldr r z Nil == z -vfoldr :: (a -> b -> b) -> b -> Vec n a -> b -vfoldr _ z Nil = z -vfoldr f z (x :> xs) = f x (vfoldr f z xs) - -{-# NOINLINE vfoldl #-} --- | 'vfoldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a vector, reduces the vector --- using the binary operator, from left to right: --- --- > vfoldl f z (xn :> ... :> x2 :> x1 :> Nil) == (...((z `f` xn)... `f` x2) `f` x1 --- > vfoldl f z Nil == z -vfoldl :: (b -> a -> b) -> b -> Vec n a -> b -vfoldl _ z Nil = z -vfoldl f z (x :> xs) = vfoldl f (f z x) xs - -{-# NOINLINE vfoldr1 #-} --- | 'vfoldr1' is a variant of 'vfoldr' that has no starting value argument, --- and thus must be applied to non-empty vectors. --- --- > vfoldr1 f (xn :> ... :> x3 :> x2 :> x1 :> Nil) == xn `f` (... (x3 `f` (x2 `f` x1))...) --- > vfoldr1 f (x1 :> Nil) == x1 --- > vfoldr1 f Nil == TYPE ERROR -vfoldr1 :: (a -> a -> a) -> Vec (n + 1) a -> a -vfoldr1 _ (x :> Nil) = x -vfoldr1 f (x :> (y :> ys)) = f x (vfoldr1 f (y :> ys)) - -{-# INLINEABLE vfoldl1 #-} --- | 'vfoldl1' is a variant of 'vfoldl' that has no starting value argument, --- and thus must be applied to non-empty vectors. --- --- > vfoldl f (xn :> xn1 :> ... :> x2 :> x1 :> Nil) == (...((xn `f` xn1)... `f` x2) `f` x1 --- > vfoldl f (x1 :> Nil) == x1 --- > vfoldl f Nil == TYPE ERROR -vfoldl1 :: (a -> a -> a) -> Vec (n + 1) a -> a -vfoldl1 f xs = vfoldl f (vhead xs) (vtail xs) - -{-# INLINEABLE vscanl #-} -vscanl :: KnownNat n => (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b -vscanl f z xs = ws - where - ws = z :> vzipWith f (lazyV (vinit ws)) xs - -{-# INLINEABLE vscanl1 #-} -vscanl1 :: KnownNat n => (a -> a -> a) -> Vec n a -> Vec n a -vscanl1 f xs = vinit (vscanl f (vhead xs') (vtail xs')) - where - xs' = xs <: undefined - -{-# INLINEABLE vscanr #-} -vscanr :: KnownNat n => (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b -vscanr f z xs = ws - where - ws = vzipWith f xs (lazyV (vtail ws)) <: z - -{-# INLINEABLE vscanr1 #-} -vscanr1 :: KnownNat n => (a -> a -> a) -> Vec n a -> Vec n a -vscanr1 f xs = vtail (vscanr f (vlast xs') (vinit xs')) - where - xs' = undefined :> xs - -{-# INLINEABLE vmapAccumL #-} -vmapAccumL :: KnownNat n => (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc,Vec n y) -vmapAccumL f acc xs = (acc',ys) - where - ws = vscanl (\l r -> f (fst l) r) (acc,undefined) xs - acc' = fst (vlast ws) - ys = vmap snd (vtail ws) - -{-# INLINEABLE vmapAccumR #-} -vmapAccumR :: KnownNat n => (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc, Vec n y) -vmapAccumR f acc xs = (acc',ys) - where - ws = vscanr (\l r -> f (fst r) l) (acc,undefined) xs - acc' = fst (vhead ws) - ys = vmap snd (vinit ws) - -{-# INLINEABLE vzip #-} --- | 'vzip' takes two vectors and returns a vector of corresponding pairs. --- --- >>> vzip (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) --- <(1,4),(2,3),(3,2),(4,1)> -vzip :: Vec n a -> Vec n b -> Vec n (a,b) -vzip = vzipWith (,) - -{-# INLINEABLE vunzip #-} --- | 'vunzip' transforms a vector of pairs into a vector of first components --- and a vector of second components. --- --- >>> vunzip ((1,4):>(2,3):>(3,2):>(4,1):>Nil) --- (<1,2,3,4>,<4,3,2,1>) -vunzip :: Vec n (a,b) -> (Vec n a, Vec n b) -vunzip xs = (vmap fst xs, vmap snd xs) - -{-# NOINLINE vindexM_integer #-} -vindexM_integer :: Vec n a -> Integer -> Maybe a -vindexM_integer Nil _ = Nothing -vindexM_integer (x :> _) 0 = Just x -vindexM_integer (_ :> xs) n = vindexM_integer xs (n-1) - -{-# NOINLINE vindex_integer #-} -vindex_integer :: KnownNat n => Vec n a -> Integer -> a -vindex_integer xs i = case vindexM_integer xs (maxIndex xs - i) of - Just a -> a - Nothing -> error ("(!): Index " ++ show i ++ " is out of bounds 0 and " ++ show (maxIndex xs)) - -{-# INLINEABLE (!) #-} --- | Vector index (subscript) operator, DESCENDING from 'maxIndex', where the --- last element has subscript 0. --- --- >>> (1:>2:>3:>4:>5:>Nil) ! 4 --- 1 --- >>> (1:>2:>3:>4:>5:>Nil) ! maxIndex --- 1 --- >>> (1:>2:>3:>4:>5:>Nil) ! 1 --- 4 --- >>> (1:>2:>3:>4:>5:>Nil) ! 14 --- *** Exception: index out of bounds -(!) :: (KnownNat n, Integral i) => Vec n a -> i -> a -xs ! i = vindex_integer xs (toInteger i) - -{-# NOINLINE maxIndex #-} --- | Index (subscript) of the head of the 'Vec'tor --- --- >>> maxIndex (6 :> 7 :> 8 :> Nil) --- 2 -maxIndex :: KnownNat n => Vec n a -> Integer -maxIndex = subtract 1 . vlength - -{-# NOINLINE vlength #-} --- | Length of a 'Vec'tor as an Integer --- --- >>> vlength (6 :> 7 :> 8 :> Nil) --- 3 -vlength :: KnownNat n => Vec n a -> Integer -vlength = natVal . asNatProxy - -{-# NOINLINE vreplaceM_integer #-} -vreplaceM_integer :: Vec n a -> Integer -> a -> Maybe (Vec n a) -vreplaceM_integer Nil _ _ = Nothing -vreplaceM_integer (_ :> xs) 0 y = Just (y :> xs) -vreplaceM_integer (x :> xs) n y = case vreplaceM_integer xs (n-1) y of - Just xs' -> Just (x :> xs') - Nothing -> Nothing - -{-# NOINLINE vreplace_integer #-} -vreplace_integer :: KnownNat n => Vec n a -> Integer -> a -> Vec n a -vreplace_integer xs i a = case vreplaceM_integer xs (maxIndex xs - i) a of - Just ys -> ys - Nothing -> error ("vreplace: Index " ++ show i ++ " is out of bounds 0 and " ++ show (maxIndex xs)) - -{-# INLINEABLE vreplace #-} --- | Replace an element of a vector at the given index (subscript). --- --- NB: vector elements have a descending subscript starting from 'maxIndex' and --- ending at 0 --- --- >>> vreplace (1:>2:>3:>4:>5:>Nil) 3 7 --- <1,7,3,4,5> --- >>> vreplace (1:>2:>3:>4:>5:>Nil) 0 7 --- <1,2,3,4,7> --- >>> vreplace (1:>2:>3:>4:>5:>Nil) 9 7 --- <*** Exception: index out of bounds -vreplace :: (KnownNat n, Integral i) => Vec n a -> i -> a -> Vec n a -vreplace xs i y = vreplace_integer xs (toInteger i) y - -{-# NOINLINE vtake #-} --- | 'vtake' @n@, applied to a vector @xs@, returns the @n@-length prefix of @xs@ --- --- >>> vtake (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) --- <1,2,3> --- >>> vtake d3 (1:>2:>3:>4:>5:>Nil) --- <1,2,3> --- >>> vtake d0 (1:>2:>Nil) --- <> --- >>> vtake d4 (1:>2:>Nil) --- --- Couldn't match type ‘4 + n0’ with ‘2’ --- The type variable ‘n0’ is ambiguous --- Expected type: Vec (4 + n0) a --- Actual type: Vec (1 + 1) a --- In the second argument of ‘vtake’, namely ‘(1 :> 2 :> Nil)’ --- In the expression: vtake d4 (1 :> 2 :> Nil) --- In an equation for ‘it’: it = vtake d4 (1 :> 2 :> Nil) -vtake :: SNat m -> Vec (m + n) a -> Vec m a -vtake n = fst . vsplit n - -{-# INLINEABLE vtakeI #-} --- | 'vtakeI' @xs@, returns the prefix of @xs@ as demanded by the context --- --- >>> vtakeI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int --- <1,2> -vtakeI :: KnownNat m => Vec (m + n) a -> Vec m a -vtakeI = withSNat vtake - -{-# NOINLINE vdrop #-} --- | 'vdrop' @n xs@ returns the suffix of @xs@ after the first @n@ elements --- --- >>> vdrop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> vdrop d3 (1:>2:>3:>4:>5:>Nil) --- <4,5> --- >>> vdrop d0 (1:>2:>Nil) --- <1,2> --- >>> vdrop d4 (1:>2:>Nil) --- --- Couldn't match expected type ‘2’ with actual type ‘4 + n0’ --- The type variable ‘n0’ is ambiguous --- In the first argument of ‘print’, namely ‘it’ --- In a stmt of an interactive GHCi command: print it -vdrop :: SNat m -> Vec (m + n) a -> Vec n a -vdrop n = snd . vsplit n - -{-# INLINEABLE vdropI #-} --- | 'vdropI' @xs@, returns the suffix of @xs@ as demanded by the context --- --- >>> vdropI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int --- <4,5> -vdropI :: KnownNat m => Vec (m + n) a -> Vec n a -vdropI = withSNat vdrop - -{-# NOINLINE vexact #-} --- | 'vexact' @n xs@ returns @n@'th element of @xs@ --- --- NB: vector elements have a descending subscript starting from 'maxIndex' and --- ending at 0 --- --- >>> vexact (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil) --- 4 --- >>> vexact d1 (1:>2:>3:>4:>5:>Nil) --- 4 -vexact :: SNat m -> Vec (m + (n + 1)) a -> a -vexact n xs = vhead $ snd $ vsplit n (vreverse xs) - -{-# NOINLINE vselect #-} --- | 'vselect' @f s n xs@ selects @n@ elements with stepsize @s@ and --- offset @f@ from @xs@ --- --- >>> vselect (snat :: SNat 1) (snat :: SNat 2) (snat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil) --- <2,4,6> --- >>> vselect d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) --- <2,4,6> -vselect :: ((f + (s * n) + 1) <= i) - => SNat f - -> SNat s - -> SNat (n + 1) - -> Vec i a - -> Vec (n + 1) a -vselect f s n xs = vselect' (toUNat n) $ vdrop f (unsafeCoerce xs) - where - vselect' :: UNat n -> Vec m a -> Vec n a - vselect' UZero _ = Nil - vselect' (USucc n') vs@(x :> _) = x :> vselect' n' (vdrop s (unsafeCoerce vs)) - -{-# INLINEABLE vselectI #-} --- | 'vselectI' @f s xs@ selects as many elements as demanded by the context --- with stepsize @s@ and offset @f@ from @xs@ --- --- >>> vselectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int --- <2,4> -vselectI :: ((f + (s * n) + 1) <= i, KnownNat (n + 1)) - => SNat f - -> SNat s - -> Vec i a - -> Vec (n + 1) a -vselectI f s xs = withSNat (\n -> vselect f s n xs) - -{-# NOINLINE vcopy #-} --- | 'vcopy' @n a@ returns a vector that has @n@ copies of @a@ --- --- >>> vcopy (snat :: SNat 3) 6 --- <6,6,6> --- >>> vcopy d3 6 --- <6,6,6> -vcopy :: SNat n -> a -> Vec n a -vcopy n a = vreplicateU (toUNat n) a - -vreplicateU :: UNat n -> a -> Vec n a -vreplicateU UZero _ = Nil -vreplicateU (USucc s) x = x :> vreplicateU s x - -{-# INLINEABLE vcopyI #-} --- | 'vcopyI' @a@ creates a vector with as many copies of @a@ as demanded by the --- context --- --- >>> vcopy 6 :: Vec 5 Int --- <6,6,6,6,6> -vcopyI :: KnownNat n => a -> Vec n a -vcopyI = withSNat vcopy - -{-# NOINLINE viterate #-} --- | 'viterate' @n f x@ returns a vector starting with @x@ followed by @n@ --- repeated applications of @f@ to @x@ --- --- > viterate (snat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) --- > viterate d4 f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) -viterate :: SNat n -> (a -> a) -> a -> Vec n a -viterate n f a = viterateU (toUNat n) f a - -viterateU :: UNat n -> (a -> a) -> a -> Vec n a -viterateU UZero _ _ = Nil -viterateU (USucc s) g x = x :> viterateU s g (g x) - -{-# INLINEABLE viterateI #-} --- | 'viterate' @f x@ returns a vector starting with @x@ followed by @n@ --- repeated applications of @f@ to @x@, where @n@ is determined by the context --- --- > viterateI f x :: Vec 3 a == (x :> f x :> f (f x) :> Nil) -viterateI :: KnownNat n => (a -> a) -> a -> Vec n a -viterateI = withSNat viterate - -{-# INLINEABLE vgenerate #-} --- | 'vgenerate' @n f x@ returns a vector with @n@ repeated applications of @f@ --- to @x@ --- --- > vgenerate (snat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) --- > vgenerate d4 f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) -vgenerate :: SNat n -> (a -> a) -> a -> Vec n a -vgenerate n f a = viterate n f (f a) - -{-# INLINEABLE vgenerateI #-} --- | 'vgenerate' @f x@ returns a vector with @n@ repeated applications of @f@ --- to @x@, where @n@ is determined by the context --- --- > vgenerateI f x :: Vec 3 a == (f x :> f (f x) :> f (f (f x)) :> Nil) -vgenerateI :: KnownNat n => (a -> a) -> a -> Vec n a -vgenerateI = withSNat vgenerate - -{-# INLINEABLE toList #-} --- | Convert a vector to a list --- --- >>> toList (1:>2:>3:>Nil) --- [1,2,3] -toList :: Vec n a -> [a] -toList = vfoldr (:) [] - --- | Create a vector literal from a list literal --- --- > $(v [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8) --- --- >>> [1 :: Signed 8,2,3,4,5] --- [1,2,3,4,5] --- >>> $(v [1::Signed 8,2,3,4,5]) --- <1,2,3,4,5> -v :: Lift a => [a] -> ExpQ -v [] = [| Nil |] -v (x:xs) = [| x :> $(v xs) |] - --- | 'Vec'tor as a 'Proxy' for 'Nat' -asNatProxy :: Vec n a -> Proxy n -asNatProxy _ = Proxy - -{-# NOINLINE lazyV #-} --- | For when your vector functions are too strict in their arguments --- --- For example: --- --- > -- Bubble sort for 1 iteration --- > sortV xs = vmap fst sorted <: (snd (vlast sorted)) --- > where --- > lefts = vhead xs :> vmap snd (vinit sorted) --- > rights = vtail xs --- > sorted = vzipWith compareSwapL lefts rights --- > --- > -- Compare and swap --- > compareSwapL a b = if a < b then (a,b) --- > else (b,a) --- --- Will not terminate because 'vzipWith' is too strict in its second argument: --- --- >>> sortV (4 :> 1 :> 2 :> 3 :> Nil) --- <*** Exception: <> --- --- In this case, adding 'lazyV' on 'vzipWith's second argument: --- --- > sortVL xs = vmap fst sorted <: (snd (vlast sorted)) --- > where --- > lefts = vhead xs :> vmap snd (vinit sorted) --- > rights = vtail xs --- > sorted = vzipWith compareSwapL (lazyV lefts) rights --- --- Results in a successful computation: --- --- >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil) --- <1,2,3,4> -lazyV :: KnownNat n - => Vec n a - -> Vec n a -lazyV = lazyV' (vcopyI undefined) - where - lazyV' :: Vec n a -> Vec n a -> Vec n a - lazyV' Nil _ = Nil - lazyV' (_ :> xs) ys = vhead ys :> lazyV' xs (vtail ys) - -{-# NOINLINE vhead' #-} --- | Same as 'vhead', but with a "@(1 <= n)@" constraint and "@Vec n a@" argument, --- instead of a "@Vec (n + 1) a@" argument -vhead' :: (1 <= n) - => Vec n a - -> a -vhead' (x :> _) = x +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module CLaSH.Sized.Vector + ( -- * 'Vec'tor constructors + Vec(..), (<:), singleton + -- * Standard 'Vec'tor functions + -- ** Extracting sub-'Vec'tors + , head, tail, last, init + , take, takeI, drop, dropI, exact, select, selectI + -- ** Combining 'Vec'tors + , (++), (+>>), (<<+), concat, zip, unzip, shiftInAt0, shiftInAtN + , shiftOutFrom0, shiftOutFromN + -- ** Splitting 'Vec'tors + , splitAt, splitAtI, unconcat, unconcatI, merge + -- ** Applying functions to 'Vec'tor elements + , map, zipWith + , foldr, foldl, foldr1, foldl1, fold + , scanl, scanr, sscanl, sscanr + , mapAccumL, mapAccumR + -- ** Indexing 'Vec'tors + , (!!), replace, maxIndex, length + -- ** Generating 'Vec'tors + , replicate, repeat, iterate, iterateI, generate, generateI + -- ** Misc + , reverse, toList, v, lazyV, asNatProxy + -- ** Functions for the 'CLaSH.Class.BitPack.BitPack' instance + , concatBitVector# + , unconcatBitVector# + ) +where + +import Control.Applicative (Applicative (..), (<$>)) +import Data.Default (Default (..)) +import qualified Data.Foldable as F +import Data.Proxy (Proxy (..)) +import Data.Traversable (Traversable (..)) +import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (*), + natVal) +import Language.Haskell.TH (ExpQ) +import Language.Haskell.TH.Syntax (Lift(..)) +import Prelude hiding ((++), (!!), concat, drop, foldl, + foldl1, foldr, foldr1, head, init, + iterate, last, length, map, repeat, + replicate, reverse, scanl, scanr, + splitAt, tail, take, unzip, zip, + zipWith) +import qualified Prelude as P +import Unsafe.Coerce (unsafeCoerce) + +import CLaSH.Promoted.Nat (SNat (..), UNat (..), withSNat, toUNat) +import CLaSH.Sized.Internal.BitVector (BitVector, (++#), split#) + +-- | Fixed size vectors +-- +-- * Lists with their length encoded in their type +-- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and +-- ending at 'maxIndex' (== 'length' - 1). +-- +-- >>> (3:>4:>5:>Nil) +-- <3,4,5> +-- >>> :t (3:>4:>5:>Nil) +-- (3:>4:>5:>Nil) :: Num a => Vec 3 a +data Vec :: Nat -> * -> * where + Nil :: Vec 0 a + (:>) :: a -> Vec n a -> Vec (n + 1) a + +infixr 5 :> + +instance Show a => Show (Vec n a) where + show vs = "<" P.++ punc vs P.++ ">" + where + punc :: Show a => Vec m a -> String + punc Nil = "" + punc (x :> Nil) = show x + punc (x :> xs) = show x P.++ "," P.++ punc xs + +instance Eq a => Eq (Vec n a) where + (==) = eq# + (/=) = neq# + +{-# NOINLINE eq# #-} +eq# :: Eq a => Vec n a -> Vec n a -> Bool +eq# v1 v2 = foldr (&&) True (zipWith (==) v1 v2) + +{-# NOINLINE neq# #-} +neq# :: Eq a => Vec n a -> Vec n a -> Bool +neq# v1 v2 = not (eq# v1 v2) + +-- | __NB__: Not synthesisable +instance KnownNat n => Applicative (Vec n) where + pure = repeat + fs <*> xs = zipWith ($) fs xs + +instance F.Foldable (Vec n) where + foldr = foldr + +instance Functor (Vec n) where + fmap = map + +-- | __NB__: Not synthesisable +instance Traversable (Vec n) where + traverse = traverse# + +{-# NOINLINE traverse# #-} +traverse# :: Applicative f => (a -> f b) -> Vec n a -> f (Vec n b) +traverse# _ Nil = pure Nil +traverse# f (x :> xs) = (:>) <$> f x <*> traverse# f xs + +instance (Default a, KnownNat n) => Default (Vec n a) where + def = repeat def + +{-# INLINE singleton #-} +-- | Create a vector of one element +-- +-- >>> singleton 5 +-- <5> +singleton :: a -> Vec 1 a +singleton = (:> Nil) + +{-# NOINLINE head #-} +-- | Extract the first element of a vector +-- +-- >>> head (1:>2:>3:>Nil) +-- 1 +-- >>> head Nil +-- +-- Couldn't match type ‘1’ with ‘0’ +-- Expected type: Vec (0 + 1) a +-- Actual type: Vec 0 a +-- In the first argument of ‘vhead’, namely ‘Nil’ +-- In the expression: vhead Nil +head :: Vec (n + 1) a -> a +head (x :> _) = x + +{-# NOINLINE tail #-} +-- | Extract the elements after the head of a vector +-- +-- >>> tail (1:>2:>3:>Nil) +-- <2,3> +-- >>> tail Nil +-- +-- Couldn't match type ‘1’ with ‘0’ +-- Expected type: Vec (0 + 1) a +-- Actual type: Vec 0 a +-- In the first argument of ‘vtail’, namely ‘Nil’ +-- In the expression: vtail Nil +tail :: Vec (n + 1) a -> Vec n a +tail (_ :> xs) = unsafeCoerce xs + +{-# NOINLINE last #-} +-- | Extract the last element of a vector +-- +-- >>> last (1:>2:>3:>Nil) +-- 3 +-- >>> last Nil +-- +-- Couldn't match type ‘1’ with ‘0’ +-- Expected type: Vec (0 + 1) a +-- Actual type: Vec 0 a +-- In the first argument of ‘vlast’, namely ‘Nil’ +-- In the expression: vlast Nil +last :: Vec (n + 1) a -> a +last (x :> Nil) = x +last (_ :> y :> ys) = last (y :> ys) + +{-# NOINLINE init #-} +-- | Extract all the elements of a vector except the last element +-- +-- >>> init (1:>2:>3:>Nil) +-- <1,2> +-- >>> init Nil +-- +-- Couldn't match type ‘1’ with ‘0’ +-- Expected type: Vec (0 + 1) a +-- Actual type: Vec 0 a +-- In the first argument of ‘vinit’, namely ‘Nil’ +-- In the expression: vinit Nil +init :: Vec (n + 1) a -> Vec n a +init (_ :> Nil) = unsafeCoerce Nil +init (x :> y :> ys) = unsafeCoerce (x :> init (y :> ys)) + +{-# INLINE shiftInAt0 #-} +-- | Shift in elements to the head of a vector, bumping out elements at the +-- tail. The result is a tuple containing: +-- +-- * The new vector +-- * The shifted out elements +-- +-- >>> shiftInAt0 (1 :> 2 :> 3 :> 4 :> Nil) ((-1) :> 0 :> Nil) +-- (<-1,0,1,2,>,<3,4>) +-- >>> shiftInAt0 (1 :> Nil) ((-1) :> 0 :> Nil) +-- (<-1>,<0,1>) +shiftInAt0 :: KnownNat n + => Vec n a -- ^ The old vector + -> Vec m a -- ^ The elements to shift in at the head + -> (Vec n a, Vec m a) -- ^ (The new vector, shifted out elements) +shiftInAt0 xs ys = splitAtI (unsafeCoerce zs) + where + zs = ys ++ xs + +{-# INLINE shiftInAtN #-} +-- | Shift in element to the tail of a vector, bumping out elements at the head. +-- The result is a tuple containing: +-- +-- * The new vector +-- * The shifted out elements +-- +-- >>> shiftInAtN (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> Nil) +-- (<3,4,5,6>,<1,2>) +-- >>> shiftInAtN (1 :> Nil) (2 :> 3 :> Nil) +-- (<3>,<1,2>) +shiftInAtN :: KnownNat m + => Vec n a -- ^ The old vector + -> Vec m a -- ^ The elements to shift in at the tail + -> (Vec n a,Vec m a) -- ^ (The new vector, shifted out elements) +shiftInAtN xs ys = (zsR, zsL) + where + zs = xs ++ ys + (zsL,zsR) = splitAtI (unsafeCoerce zs) + +infixl 5 <: +{-# INLINE (<:) #-} +-- | Add an element to the tail of a vector. +-- +-- >>> (3:>4:>5:>Nil) <: 1 +-- <3,4,5,1> +-- >>> :t (3:>4:>5:>Nil) <: 1 +-- (3:>4:>5:>Nil) <: 1 :: Num a => Vec 4 a +(<:) :: Vec n a -> a -> Vec (n + 1) a +xs <: x = xs ++ singleton x + +infixr 4 +>> +{-# INLINE (+>>) #-} +-- | Add an element to the head of a vector, and extract all but the last +-- element. +-- +-- >>> 1 +>> (3:>4:>5:>Nil) +-- <1,3,4> +-- >>> 1 +>> Nil +-- <> +(+>>) :: KnownNat n => a -> Vec n a -> Vec n a +s +>> xs = fst (shiftInAt0 xs (singleton s)) + +infixl 4 <<+ +{-# INLINE (<<+) #-} +-- | Add an element to the tail of a vector, and extract all but the first +-- element. +-- +-- >>> (3:>4:>5:>Nil) <<+ 1 +-- <4,5,1> +-- >>> Nil <<+ 1 +-- <> +(<<+) :: KnownNat n => Vec n a -> a -> Vec n a +xs <<+ s = fst (shiftInAtN xs (singleton s)) + +{-# INLINE shiftOutFrom0 #-} +-- | Shift @m@ elements out from the head of a vector, filling up the tail with +-- 'Default' values. The result is a tuple containing: +-- +-- * The new vector +-- * The shifted out values +-- +-- >>> shiftOutFrom0 d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) +-- (<3,4,5,0,0>,<1,2>) +shiftOutFrom0 :: (Default a, KnownNat m) + => SNat m -- ^ @m@, the number of elements to shift out + -> Vec (m + n) a -- ^ The old vector + -> (Vec (m + n) a, Vec m a) + -- ^ (The new vector, shifted out elements) +shiftOutFrom0 m xs = shiftInAtN xs (replicate m def) + +{-# INLINE shiftOutFromN #-} +-- | Shift @m@ elements out from the tail of a vector, filling up the head with +-- 'Default' values. The result is a tuple containing: +-- +-- * The new vector +-- * The shifted out values +-- +-- >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) +-- (<0,0,1,2,3>,<4,5>) +shiftOutFromN :: (Default a, KnownNat (m + n)) + => SNat m -- ^ @m@, the number of elements to shift out + -> Vec (m + n) a -- ^ The old vector + -> (Vec (m + n) a, Vec m a) + -- ^ (The new vector, shifted out elements) +shiftOutFromN m xs = shiftInAt0 xs (replicate m def) + +infixr 5 ++ +{-# NOINLINE (++) #-} +-- | Append two vectors +-- +-- >>> (1:>2:>3:>Nil) ++ (7:>8:>Nil) +-- <1,2,3,7,8> +(++) :: Vec n a -> Vec m a -> Vec (n + m) a +Nil ++ ys = ys +(x :> xs) ++ ys = unsafeCoerce (x :> (xs ++ ys)) + +{-# NOINLINE splitAt #-} +-- | Split a vector into two vectors at the given point +-- +-- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil) +-- (<1,2,3>, <7,8>) +-- >>> splitAt d3 (1:>2:>3:>7:>8:>Nil) +-- (<1,2,3>, <7,8>) +splitAt :: SNat m -> Vec (m + n) a -> (Vec m a, Vec n a) +splitAt n xs = splitAtU (toUNat n) xs + +splitAtU :: UNat m -> Vec (m + n) a -> (Vec m a, Vec n a) +splitAtU UZero ys = (Nil,ys) +splitAtU (USucc s) (y :> ys) = let (as,bs) = splitAtU s (unsafeCoerce ys) + in (y :> as, bs) + +{-# INLINE splitAtI #-} +-- | Split a vector into two vectors where the length of the two is determined +-- by the context +-- +-- >>> splitAtI (1:>2:>3:>7:>8:>Nil) :: (Vec 2 Int, Vec 3 Int) +-- (<1,2>,<3,7,8>) +splitAtI :: KnownNat m => Vec (m + n) a -> (Vec m a, Vec n a) +splitAtI = withSNat splitAt + +{-# NOINLINE concat #-} +-- | Concatenate a vector of vectors +-- +-- >>> vconcat ((1:>2:>3:>Nil) :> (4:>5:>6:>Nil) :> (7:>8:>9:>Nil) :> (10:>11:>12:>Nil) :> Nil) +-- <1,2,3,4,5,6,7,8,9,10,11,12> +concat :: Vec n (Vec m a) -> Vec (n * m) a +concat Nil = Nil +concat (x :> xs) = unsafeCoerce (x ++ (concat xs)) + +{-# NOINLINE unconcat #-} +-- | Split a vector of (n * m) elements into a vector of vectors with length m, +-- where m is given +-- +-- >>> vunconcat d4 (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) +-- <<1,2,3,4>,<5,6,7,8>,<9,10,11,12>> +unconcat :: KnownNat n => SNat m -> Vec (n * m) a -> Vec n (Vec m a) +unconcat n xs = unconcatU (withSNat toUNat) (toUNat n) xs + +unconcatU :: UNat n -> UNat m -> Vec (n * m) a -> Vec n (Vec m a) +unconcatU UZero _ _ = Nil +unconcatU (USucc n') m ys = let (as,bs) = splitAtU m (unsafeCoerce ys) + in as :> unconcatU n' m bs + +{-# INLINE unconcatI #-} +-- | Split a vector of (n * m) elements into a vector of vectors with length m, +-- where m is determined by the context +-- +-- >>> vunconcatI (1:>2:>3:>4:>5:>6:>7:>8:>9:>10:>11:>12:>Nil) :: Vec 2 (Vec 6 Int) +-- <<1,2,3,4,5,6>,<7,8,9,10,11,12>> +unconcatI :: (KnownNat n, KnownNat m) => Vec (n * m) a -> Vec n (Vec m a) +unconcatI = withSNat unconcat + +{-# NOINLINE merge #-} +-- | Merge two vectors, alternating their elements, i.e., +-- +-- >>> merge (1 :> 2 :> 3 :> 4 :> Nil) (5 :> 6 :> 7 :> 8 :> Nil) +-- <1,5,2,6,3,7,4,8> +merge :: Vec n a -> Vec n a -> Vec (n + n) a +merge Nil Nil = Nil +merge (x :> xs) (y :> ys) = unsafeCoerce + (x :> y :> (merge xs (unsafeCoerce ys))) + +{-# NOINLINE reverse #-} +-- | Returns the elements in a vector in reverse order +-- +-- >>> reverse (1:>2:>3:>4:>Nil) +-- <4,3,2,1> +reverse :: Vec n a -> Vec n a +reverse Nil = Nil +reverse (x :> xs) = reverse xs <: x + +{-# NOINLINE map #-} +-- | 'map' @f xs@ is the vector obtained by applying @f@ to each element +-- of @xs@, i.e., +-- +-- > map f (x1 :> x2 :> ... :> xn :> Nil) == (f x1 :> f x2 :> ... :> f xn :> Nil) +map :: (a -> b) -> Vec n a -> Vec n b +map _ Nil = Nil +map f (x :> xs) = f x :> map f xs + +{-# NOINLINE zipWith #-} +-- | 'zipWith' generalises 'zip' by zipping with the function given +-- as the first argument, instead of a tupling function. +-- For example, @'zipWith' (+)@ is applied to two vectors to produce the +-- vector of corresponding sums. +-- +-- > zipWith f (x1 :> x2 :> ... xn :> Nil) (y1 :> y2 :> ... :> yn :> Nil) == (f x1 y1 :> f x2 y2 :> ... :> f xn yn :> Nil) +-- +-- __NB:__ 'zipWith' is /strict/ in its second argument, and /lazy/ in its +-- third. This matters when 'zipWith' is used in a recursive setting. See +-- 'lazyV' for more information. +zipWith :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c +zipWith _ Nil _ = Nil +zipWith f (x :> xs) ys = f x (head ys) :> zipWith f xs (tail ys) + +{-# INLINABLE foldr #-} +-- | 'vfoldr', applied to a binary operator, a starting value (typically +-- the right-identity of the operator), and a vector, reduces the vector +-- using the binary operator, from right to left: +-- +-- > foldr f z (x1 :> ... :> xn1 :> xn :> Nil) == x1 `f` (... (xn1 `f` (xn `f` z))...) +-- > foldr r z Nil == z +-- +-- >>> foldr (/) 1 (5 :> 4 :> 3 :> 2 :> Nil) +-- 1.875 +-- +-- __NB__: @"'foldr' f z xs"@ produces a linear structure, which has a depth, or +-- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is +-- associative, as @"'fold' f xs"@ produces a structure with a depth of +-- O(log_2(@'length' xs@)). +foldr :: (a -> b -> b) -> b -> Vec n a -> b +foldr f z xs = head (scanr f z xs) + +{-# INLINABLE foldl #-} +-- | 'foldl', applied to a binary operator, a starting value (typically +-- the left-identity of the operator), and a vector, reduces the vector +-- using the binary operator, from left to right: +-- +-- > foldl f z (x1 :> x2 :> ... :> xn :> Nil) == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- > foldl f z Nil == z +-- +-- >>> foldl (/) 1 (5 :> 4 :> 3 :> 2 :> Nil) +-- 8.333333333333333e-3 +-- +-- __NB__: @"'foldl' f z xs"@ produces a linear structure, which has a depth, or +-- delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is +-- associative, as @"'fold' f xs"@ produces a structure with a depth of +-- O(log_2(@'length' xs@)). +foldl :: (b -> a -> b) -> b -> Vec n a -> b +foldl f z xs = last (scanl f z xs) + +{-# INLINABLE foldr1 #-} +-- | 'foldr1' is a variant of 'foldr' that has no starting value argument, +-- and thus must be applied to non-empty vectors. +-- +-- > foldr1 f (x1 :> ... :> xn2 :> xn1 :> xn :> Nil) == x1 `f` (... (xn2 `f` (xn1 `f` xn))...) +-- > foldr1 f (x1 :> Nil) == x1 +-- > foldr1 f Nil == TYPE ERROR +-- +-- >>> foldr1 (/) (5 :> 4 :> 3 :> 2 :> 1 :> Nil) +-- 1.875 +-- +-- __NB__: @"'foldr1' f z xs"@ produces a linear structure, which has a depth, +-- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is +-- associative, as @"'fold' f xs"@ produces a structure with a depth of +-- O(log_2(@'length' xs@)). +foldr1 :: (a -> a -> a) -> Vec (n + 1) a -> a +foldr1 f xs = foldr f (last xs) (init xs) + +{-# INLINE foldl1 #-} +-- | 'foldl1' is a variant of 'foldl' that has no starting value argument, +-- and thus must be applied to non-empty vectors. +-- +-- > foldl1 f (x1 :> x2 :> x3 :> ... :> xn :> Nil) == (...((x1 `f` x2) `f` x3) `f`...) `f` xn +-- > foldl1 f (x1 :> Nil) == x1 +-- > foldl1 f Nil == TYPE ERROR +-- +-- >>> foldl1 (/) (1 :> 5 :> 4 :> 3 :> 2 :> Nil) +-- 8.333333333333333e-3 +-- +-- __NB__: @"'foldl1' f z xs"@ produces a linear structure, which has a depth, +-- or delay, of O(@'length' xs@). Use 'fold' if your binary operator @f@ is +-- associative, as @"'fold' f xs"@ produces a structure with a depth of +-- O(log_2(@'length' xs@)). +foldl1 :: (a -> a -> a) -> Vec (n + 1) a -> a +foldl1 f xs = foldl f (head xs) (tail xs) + +{-# NOINLINE fold #-} +-- | 'fold' is a variant of 'foldr1' and 'foldl1', but instead of reducing from +-- right to left, or left to right, it reduces a vector using a tree-like +-- structure. The depth, or delay, of the structure produced by +-- \"@'fold' f xs@\", is hence @O(log_2('length' xs))@, and not +-- @O('length' xs)@. +-- +-- __NB__: The binary operator \"@f@ in @'fold' f xs@\" must be associative. +-- +-- > fold f (x1 :> x2 :> ... :> xn1 :> xn :> Nil) == ((x1 `f` x2) `f` ...) `f` (... `f` (xn1 `f` xn)) +-- > fold f (x1 :> Nil) == x1 +-- > fold f Nil == TYPE ERROR +-- +-- >>> fold (+) (5 :> 4 :> 3 :> 2 :> 1 :> Nil) +-- 15 +fold :: (a -> a -> a) -> Vec (n + 1) a -> a +fold f vs = fold' (toList vs) + where + fold' [x] = x + fold' xs = fold' ys `f` fold' zs + where + (ys,zs) = P.splitAt (P.length xs `div` 2) xs + +{-# INLINE scanl #-} +-- | 'scanl' is similar to 'foldl', but returns a vector of successive reduced +-- values from the left: +-- +-- > scanl f z (x1 :> x2 :> ... :> Nil) == z :> (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil +-- +-- >>> scanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) +-- <0,5,9,12,14> +-- +-- __NB__: +-- +-- > last (scanl f z xs) == foldl f z xs +scanl :: (b -> a -> b) -> b -> Vec n a -> Vec (n + 1) b +scanl f z xs = ws + where + ws = z :> zipWith (flip f) xs (init ws) + +{-# INLINE sscanl #-} +-- | 'sscanl' is a variant of 'scanl' where the first result is dropped: +-- +-- > sscanl f z (x1 :> x2 :> ... :> Nil) == (z `f` x1) :> ((z `f` x1) `f` x2) :> ... :> Nil +-- +-- >>> sscanl (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) +-- <5,9,12,14> +sscanl :: (b -> a -> b) -> b -> Vec n a -> Vec n b +sscanl f z xs = tail (scanl f z xs) + +{-# INLINE scanr #-} +-- | 'scanr' is similar to 'foldr', but returns a vector of successive reduced +-- values from the right: +-- +-- > scanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> z :> Nil +-- +-- >>> scanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) +-- <14,9,5,2,0> +-- +-- __NB__: +-- +-- > head (scanr f z xs) == foldr f z xs +scanr :: (a -> b -> b) -> b -> Vec n a -> Vec (n + 1) b +scanr f z xs = ws + where + ws = zipWith f xs ((tail ws)) <: z + +{-# INLINE sscanr #-} +-- | 'sscanr' is a variant of 'scanr' that where the last result is dropped: +-- +-- > sscanr f z (... :> xn1 :> xn :> Nil) == ... :> (xn1 `f` (xn `f` z)) :> (xn `f` z) :> Nil +-- +-- >>> sscanr (+) 0 (5 :> 4 :> 3 :> 2 :> Nil) +-- <14,9,5,2> +sscanr :: (a -> b -> b) -> b -> Vec n a -> Vec n b +sscanr f z xs = init (scanr f z xs) + +{-# INLINE mapAccumL #-} +-- | The 'mapAccumL' function behaves like a combination of 'map' and 'foldl'; +-- it applies a function to each element of a vector, passing an accumulating +-- parameter from left to right, and returning a final value of this accumulator +-- together with the new vector. +-- +-- >>> mapAccumL (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil) +-- (10,<1,2,4,7>) +mapAccumL :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc,Vec n y) +mapAccumL f acc xs = (acc',ys) + where + accs = acc :> accs' + ws = zipWith (flip f) xs (init accs) + accs' = map fst ws + ys = map snd ws + acc' = last accs + +{-# INLINE mapAccumR #-} +-- | The 'mapAccumR' function behaves like a combination of 'map' and 'foldr'; +-- it applies a function to each element of a vector, passing an accumulating +-- parameter from right to left, and returning a final value of this accumulator +-- together with the new vector. +-- +-- >>> mapAccumR (\acc x -> (acc + x,acc + 1)) 0 (1 :> 2 :> 3 :> 4 :> Nil) +-- (10,<10,8,5,1>) +mapAccumR :: (acc -> x -> (acc,y)) -> acc -> Vec n x -> (acc, Vec n y) +mapAccumR f acc xs = (acc',ys) + where + accs = accs' <: acc + ws = zipWith (flip f) xs (tail accs) + accs' = map fst ws + ys = map snd ws + acc' = head accs + +{-# INLINE zip #-} +-- | 'zip' takes two vectors and returns a vector of corresponding pairs. +-- +-- >>> zip (1:>2:>3:>4:>Nil) (4:>3:>2:>1:>Nil) +-- <(1,4),(2,3),(3,2),(4,1)> +zip :: Vec n a -> Vec n b -> Vec n (a,b) +zip = zipWith (,) + +{-# INLINE unzip #-} +-- | 'unzip' transforms a vector of pairs into a vector of first components +-- and a vector of second components. +-- +-- >>> unzip ((1,4):>(2,3):>(3,2):>(4,1):>Nil) +-- (<1,2,3,4>,<4,3,2,1>) +unzip :: Vec n (a,b) -> (Vec n a, Vec n b) +unzip xs = (map fst xs, map snd xs) + +indexM_integer :: Vec n a -> Integer -> Maybe a +indexM_integer Nil _ = Nothing +indexM_integer (x :> _) 0 = Just x +indexM_integer (_ :> xs) n = indexM_integer xs (n-1) + +{-# NOINLINE index_integer #-} +index_integer :: KnownNat n => Vec n a -> Integer -> a +index_integer xs i = case indexM_integer xs i of + Just a -> a + Nothing -> error (P.concat [ "(!!): Index " + , show i + , " is out of bounds [0.." + , show (maxIndex xs) + , "]" + ]) + +{-# INLINE (!!) #-} +-- | Vector index (subscript) operator. +-- +-- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and +-- ending at 'maxIndex'. +-- +-- >>> (1:>2:>3:>4:>5:>Nil) !! 4 +-- 5 +-- >>> (1:>2:>3:>4:>5:>Nil) !! maxIndex +-- 5 +-- >>> (1:>2:>3:>4:>5:>Nil) !! 1 +-- 2 +-- >>> (1:>2:>3:>4:>5:>Nil) !! 14 +-- *** Exception: (!!): Index 14 is out of bounds [0..4] +(!!) :: (KnownNat n, Integral i) => Vec n a -> i -> a +xs !! i = index_integer xs (toInteger i) + +{-# NOINLINE maxIndex #-} +-- | Index (subscript) of the last element in a 'Vec'tor +-- +-- >>> maxIndex (6 :> 7 :> 8 :> Nil) +-- 2 +maxIndex :: KnownNat n => Vec n a -> Integer +maxIndex = subtract 1 . length + +{-# NOINLINE length #-} +-- | Length of a 'Vec'tor as an Integer +-- +-- >>> length (6 :> 7 :> 8 :> Nil) +-- 3 +length :: KnownNat n => Vec n a -> Integer +length = natVal . asNatProxy + +replaceM_integer :: Vec n a -> Integer -> a -> Maybe (Vec n a) +replaceM_integer Nil _ _ = Nothing +replaceM_integer (_ :> xs) 0 y = Just (y :> xs) +replaceM_integer (x :> xs) n y = case replaceM_integer xs (n-1) y of + Just xs' -> Just (x :> xs') + Nothing -> Nothing + +{-# NOINLINE replace_integer #-} +replace_integer :: KnownNat n => Vec n a -> Integer -> a -> Vec n a +replace_integer xs i a = case replaceM_integer xs i a of + Just ys -> ys + Nothing -> error (P.concat [ "replace: Index " + , show i + , " is out of bounds [0.." + , show (maxIndex xs) + , "]" + ]) + +{-# INLINE replace #-} +-- | Replace an element of a vector at the given index (subscript). +-- +-- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and +-- ending at 'maxIndex'. +-- +-- >>> replace (1:>2:>3:>4:>5:>Nil) 3 7 +-- <1,2,3,7,5> +-- >>> replace (1:>2:>3:>4:>5:>Nil) 0 7 +-- <7,2,3,4,5> +-- >>> replace (1:>2:>3:>4:>5:>Nil) 9 7 +-- <*** Exception: replace: Index 9 is out of bounds [0..4] +replace :: (KnownNat n, Integral i) => Vec n a -> i -> a -> Vec n a +replace xs i y = replace_integer xs (toInteger i) y + +{-# INLINABLE take #-} +-- | 'take' @n@, applied to a vector @xs@, returns the @n@-length prefix of @xs@ +-- +-- >>> take (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) +-- <1,2,3> +-- >>> take d3 (1:>2:>3:>4:>5:>Nil) +-- <1,2,3> +-- >>> take d0 (1:>2:>Nil) +-- <> +-- >>> take d4 (1:>2:>Nil) +-- +-- Couldn't match type ‘4 + n0’ with ‘2’ +-- The type variable ‘n0’ is ambiguous +-- Expected type: Vec (4 + n0) a +-- Actual type: Vec (1 + 1) a +-- In the second argument of ‘vtake’, namely ‘(1 :> 2 :> Nil)’ +-- In the expression: vtake d4 (1 :> 2 :> Nil) +-- In an equation for ‘it’: it = vtake d4 (1 :> 2 :> Nil) +take :: SNat m -> Vec (m + n) a -> Vec m a +take n = fst . splitAt n + +{-# INLINE takeI #-} +-- | 'takeI' @xs@, returns the prefix of @xs@ as demanded by the context +-- +-- >>> takeI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int +-- <1,2> +takeI :: KnownNat m => Vec (m + n) a -> Vec m a +takeI = withSNat take + +{-# INLINE drop #-} +-- | 'drop' @n xs@ returns the suffix of @xs@ after the first @n@ elements +-- +-- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) +-- <4,5> +-- >>> drop d3 (1:>2:>3:>4:>5:>Nil) +-- <4,5> +-- >>> drop d0 (1:>2:>Nil) +-- <1,2> +-- >>> drop d4 (1:>2:>Nil) +-- +-- Couldn't match expected type ‘2’ with actual type ‘4 + n0’ +-- The type variable ‘n0’ is ambiguous +-- In the first argument of ‘print’, namely ‘it’ +-- In a stmt of an interactive GHCi command: print it +drop :: SNat m -> Vec (m + n) a -> Vec n a +drop n = snd . splitAt n + +{-# INLINE dropI #-} +-- | 'dropI' @xs@, returns the suffix of @xs@ as demanded by the context +-- +-- >>> dropI (1:>2:>3:>4:>5:>Nil) :: Vec 2 Int +-- <4,5> +dropI :: KnownNat m => Vec (m + n) a -> Vec n a +dropI = withSNat drop + +{-# INLINE exact #-} +-- | 'exact' @n xs@ returns @n@'th element of @xs@ +-- +-- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and +-- ending at 'maxIndex'. +-- +-- >>> exact (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil) +-- 4 +-- >>> exact d1 (1:>2:>3:>4:>5:>Nil) +-- 4 +exact :: SNat m -> Vec (m + (n + 1)) a -> a +exact n xs = head $ snd $ splitAt n xs + +{-# NOINLINE select #-} +-- | 'select' @f s n xs@ selects @n@ elements with stepsize @s@ and +-- offset @f@ from @xs@ +-- +-- >>> select (snat :: SNat 1) (snat :: SNat 2) (snat :: SNat 3) (1:>2:>3:>4:>5:>6:>7:>8:>Nil) +-- <2,4,6> +-- >>> select d1 d2 d3 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) +-- <2,4,6> +select :: (CmpNat (i + s) (s * n) ~ GT) + => SNat f + -> SNat s + -> SNat n + -> Vec (f + i) a + -> Vec n a +select f s n xs = select' (toUNat n) $ drop f xs + where + select' :: UNat n -> Vec i a -> Vec n a + select' UZero _ = Nil + select' (USucc n') vs@(x :> _) = x :> select' n' (drop s (unsafeCoerce vs)) + +{-# INLINE selectI #-} +-- | 'selectI' @f s xs@ selects as many elements as demanded by the context +-- with stepsize @s@ and offset @f@ from @xs@ +-- +-- >>> selectI d1 d2 (1:>2:>3:>4:>5:>6:>7:>8:>Nil) :: Vec 2 Int +-- <2,4> +selectI :: (CmpNat (i + s) (s * n) ~ GT, KnownNat n) + => SNat f + -> SNat s + -> Vec (f + i) a + -> Vec n a +selectI f s xs = withSNat (\n -> select f s n xs) + +{-# NOINLINE replicate #-} +-- | 'replicate' @n a@ returns a vector that has @n@ copies of @a@ +-- +-- >>> replicate (snat :: SNat 3) 6 +-- <6,6,6> +-- >>> replicate d3 6 +-- <6,6,6> +replicate :: SNat n -> a -> Vec n a +replicate n a = replicateU (toUNat n) a + +replicateU :: UNat n -> a -> Vec n a +replicateU UZero _ = Nil +replicateU (USucc s) x = x :> replicateU s x + +{-# INLINE repeat #-} +-- | 'repeat' @a@ creates a vector with as many copies of @a@ as demanded by the +-- context +-- +-- >>> repeat 6 :: Vec 5 Int +-- <6,6,6,6,6> +repeat :: KnownNat n => a -> Vec n a +repeat = withSNat replicate + +{-# INLINE iterate #-} +-- | 'iterate' @n f x@ returns a vector starting with @x@ followed by @n@ +-- repeated applications of @f@ to @x@ +-- +-- > iterate (snat :: SNat 4) f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) +-- > iterate d4 f x == (x :> f x :> f (f x) :> f (f (f x)) :> Nil) +-- +-- >>> iterate d4 (+1) 1 +-- <1,2,3,4> +iterate :: SNat n -> (a -> a) -> a -> Vec n a +iterate (SNat _) = iterateI + +{-# INLINE iterateI #-} +-- | 'iterate' @f x@ returns a vector starting with @x@ followed by @n@ +-- repeated applications of @f@ to @x@, where @n@ is determined by the context +-- +-- > iterateI f x :: Vec 3 a == (x :> f x :> f (f x) :> Nil) +-- +-- >>> iterateI (+1) 1 :: Vec 3 Int +-- <1,2,3> +iterateI :: KnownNat n => (a -> a) -> a -> Vec n a +iterateI f a = xs + where + xs = init (a :> ws) + ws = map f (lazyV xs) + +{-# INLINE generate #-} +-- | 'generate' @n f x@ returns a vector with @n@ repeated applications of @f@ +-- to @x@ +-- +-- > generate (snat :: SNat 4) f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) +-- > generate d4 f x == (f x :> f (f x) :> f (f (f x)) :> f (f (f (f x))) :> Nil) +-- +-- >>> generate d4 (+1) 1 +-- <2,3,4,5> +generate :: SNat n -> (a -> a) -> a -> Vec n a +generate (SNat _) f a = iterateI f (f a) + +{-# INLINE generateI #-} +-- | 'generate' @f x@ returns a vector with @n@ repeated applications of @f@ +-- to @x@, where @n@ is determined by the context +-- +-- > generateI f x :: Vec 3 a == (f x :> f (f x) :> f (f (f x)) :> Nil) +-- +-- >>> generateI (+1) 1 :: Vec 3 Int +-- <2,3,4> +generateI :: KnownNat n => (a -> a) -> a -> Vec n a +generateI f a = iterateI f (f a) + +{-# INLINE toList #-} +-- | Convert a vector to a list +-- +-- >>> toList (1:>2:>3:>Nil) +-- [1,2,3] +-- +-- __NB__: Not synthesisable +toList :: Vec n a -> [a] +toList = foldr (:) [] + +-- | Create a vector literal from a list literal +-- +-- > $(v [1::Signed 8,2,3,4,5]) == (8:>2:>3:>4:>5:>Nil) :: Vec 5 (Signed 8) +-- +-- >>> [1 :: Signed 8,2,3,4,5] +-- [1,2,3,4,5] +-- >>> $(v [1::Signed 8,2,3,4,5]) +-- <1,2,3,4,5> +v :: Lift a => [a] -> ExpQ +v [] = [| Nil |] +v (x:xs) = [| x :> $(v xs) |] + +-- | 'Vec'tor as a 'Proxy' for 'Nat' +asNatProxy :: Vec n a -> Proxy n +asNatProxy _ = Proxy + +{-# NOINLINE lazyV #-} +-- | For when your vector functions are too strict in their arguments +-- +-- For example: +-- +-- > -- Bubble sort for 1 iteration +-- > sortV xs = map fst sorted <: (snd (last sorted)) +-- > where +-- > lefts = head xs :> map snd (init sorted) +-- > rights = tail xs +-- > sorted = zipWith compareSwapL lefts rights +-- > +-- > -- Compare and swap +-- > compareSwapL a b = if a < b then (a,b) +-- > else (b,a) +-- +-- Will not terminate because 'zipWith' is too strict in its second argument: +-- +-- >>> sortV (4 :> 1 :> 2 :> 3 :> Nil) +-- <*** Exception: <> +-- +-- In this case, adding 'lazyV' on 'zipWith's second argument: +-- +-- @ +-- sortVL xs = map fst sorted <: (snd (last sorted)) +-- where +-- lefts = head xs :> map snd (init sorted) +-- rights = tail xs +-- sorted = zipWith compareSwapL ('lazyV' lefts) rights +-- @ +-- +-- Results in a successful computation: +-- +-- >>> sortVL (4 :> 1 :> 2 :> 3 :> Nil) +-- <1,2,3,4> +-- +-- __NB__: There is also a solution using 'flip', but it slightly obfuscates the +-- meaning of the code: +-- +-- @ +-- sortV_flip xs = map fst sorted <: (snd (last sorted)) +-- where +-- lefts = head xs :> map snd (init sorted) +-- rights = tail xs +-- sorted = zipWith ('flip' compareSwapL) rights lefts +-- @ +-- +-- >>> sortV_flip (4 :> 1 :> 2 :> 3 :> Nil) +-- <1,2,3,4> +lazyV :: KnownNat n + => Vec n a + -> Vec n a +lazyV = lazyV' (repeat undefined) + where + lazyV' :: Vec n a -> Vec n a -> Vec n a + lazyV' Nil _ = Nil + lazyV' (_ :> xs) ys = head ys :> lazyV' xs (tail ys) + +{-# NOINLINE concatBitVector# #-} +concatBitVector# :: KnownNat m + => Vec n (BitVector m) + -> BitVector (n * m) +concatBitVector# Nil = 0 +concatBitVector# (x :> xs) = unsafeCoerce (concatBitVector# xs ++# x) + +{-# NOINLINE unconcatBitVector# #-} +unconcatBitVector# :: (KnownNat n, KnownNat m) + => BitVector (n * m) + -> Vec n (BitVector m) +unconcatBitVector# bv = withSNat (\s -> ucBV (toUNat s) bv) + +{-# INLINE ucBV #-} +ucBV :: forall n m . KnownNat m + => UNat n -> BitVector (n * m) -> Vec n (BitVector m) +ucBV UZero _ = Nil +ucBV (USucc n) bv = let (bv',x :: BitVector m) = split# (unsafeCoerce bv) + in x :> ucBV n bv' diff --git a/src/CLaSH/Tutorial.hs b/src/CLaSH/Tutorial.hs --- a/src/CLaSH/Tutorial.hs +++ b/src/CLaSH/Tutorial.hs @@ -130,7 +130,7 @@ * Run @cabal update@ - (3) Install __CλaSH__ + (2) Install __CλaSH__ * Run @cabal install clash-ghc@ @@ -310,10 +310,10 @@ shape of 'macT': @ -(\<^\>) :: (Pack i, Pack o) +(\<^\>) :: (Bundle i, Bundle o) => (s -> i -> (s,o)) -> s - -> (SignalP i -> SignalP o) + -> (Unbudled' i -> Unbundled' o) f \<^\> initS = ... @ @@ -326,7 +326,7 @@ Where the LHS of '<^>' is our 'macT' function, and the RHS is the initial state, in this case 0. We can see it is functioning correctly in our interpreter: ->>> take 4 $ simulateP mac [(1::Int,1),(2,2),(3,3),(4,4)] :: [Int] +>>> Data.List.take 4 $ simulateB mac [(1::Int,1),(2,2),(3,3),(4,4)] :: [Int] [0,1,5,14] Where we simulate our sequential circuit over a list of input samples and take @@ -338,22 +338,22 @@ the type of our 'mac' circuit: >>> :t mac -mac :: (Pack o, Num o) => (Signal o, Signal o) -> SignalP o +mac :: (Bundle o, Num o) => Unbundled' (o, o) -> Unbundled o We see that our 'mac' function work on a two-tuple of 'Signal's and not on a 'Signal' of a two-tuple. Indeed, the CλaSH prelude library defines that: @ -type instance SignalP (a,b) = (Signal a, Signal b) +type instance Unbundled (a,b) = (Signal a, Signal b) @ -'SignalP' is an -belonging to the 'Pack' , -which, together with 'pack' and 'unpack' defines the isomorphism between a +'Unbundled' is an +belonging to the 'Bundle' , +which, together with 'bundle' and 'unbundle' defines the isomorphism between a product type of 'Signal's and a 'Signal' of a product type. That is, while @(Signal a, Signal b)@ and @Signal (a,b)@ are not equal, they are /isomorphic/ -and can be converted from on to the other using 'pack' and 'unpack'. Instances -of this 'Pack' type-class are defined as /isomorphisms/ for: +and can be converted from on to the other using 'bundle' and 'unbundle'. Instances +of this 'Bundle' type-class are defined as /isomorphisms/ for: * All tuples until and including 8-tuples * The 'Vec'tor type @@ -365,18 +365,18 @@ That is: @ -instance Pack Bool where - type SignalP Bool = Signal Bool - pack :: SignalP Bool -> Signal Bool - pack = 'id' - unpack :: Signal Bool -> SignalP Bool +instance Bundle Bool where + type Unbundled Bool = Signal Bool + bundle :: Unbundled Bool -> Signal Bool + bundle = 'id' + unpack :: Signal Bool -> Unbundled Bool unpack = 'id' @ -We will see later why this 'Pack' type class is so convenient, for now, you just +We will see later why this 'Bundle' type class is so convenient, for now, you just have to remember that it exists. And more importantly, that you understand that a product type of 'Signal's is not equal to a 'Signal' of a product type, but -that the functions of the 'Pack' type class allow easy conversion between the +that the functions of the 'Bunlde' type class allow easy conversion between the two. -} @@ -573,10 +573,10 @@ position of the arguments and result: @ - asStateM :: (Pack o, Pack i) + asStateM :: (Bundle o, Bundle i) => (i -> State s o) -> s - -> (SignalP i -> SignalP o) + -> (Unbundled i -> Unbundled o) asStateM f i = g \<^\> i where g s x = let (o,s') = runState (f x) s @@ -596,7 +596,7 @@ of coefficients. @ -dotp as bs = vfoldl (+) 0 (vzipWith (*) as bs) +dotp as bs = foldl (+) 0 (zipWith (*) as bs) fir coeffs x_t = y_t where @@ -662,19 +662,19 @@ => Vec n a -- Current state -> (i, Maybe a) -- Input -> (Vec n a, a) -- (New state, Output) -datamem mem (addr,Nothing) = (mem ,mem ! addr) -datamem mem (addr,Just val) = (vreplace mem addr val,mem ! addr) +datamem mem (addr,Nothing) = (mem ,mem !! addr) +datamem mem (addr,Just val) = (replace mem addr val,mem !! addr) topEntity :: Signal (OPC Word) -> Signal (Maybe Word) topEntity i = val where (addr,val) = (pu alu \<^\> (0,0,0 :: Unsigned 3)) (mem,i) mem = (datamem \<^\> initMem) (addr,val) - initMem = vcopy d8 0 + initMem = replicate d8 0 @ Here we can finally see the advantage of having the '<^>' return a function -of type: @('SignalP' i -> 'SignalP' o)@ (instead of: +of type: @('Unbundled' i -> 'Unbundled' o)@ (instead of: @('Signal' i -> 'Signal' o)@): * We can use normal pattern matching to get parts of the result, and, @@ -706,19 +706,19 @@ and /declaration/ primitives, corresponding to whether the primitive is a VHDL /expression/ or a VHDL /declaration/. We will first explore /expression/ primitives, using 'Signed' multiplication ('*') as an example. The -"CLaSH.Sized.Signed" module specifies multiplication as follows: +"CLaSH.Sized.Internal.Signed" module specifies multiplication as follows: @ -{\-# NOINLINE timesS #-\} -timesS :: KnownNat n => Signed n -> Signed n -> Signed n -timesS (S a) (S b) = fromIntegerS_inlineable (a * b) +{\-\# NOINLINE (*#) \#-\} +(*#) :: KnownNat n => Signed n -> Signed n -> Signed n +(S a) *# (S b) = fromInteger_INLINE (a * b) @ For which the /expression/ primitive is: @ { \"BlackBox\" : - { "name" : "CLaSH.Sized.Signed.timesS" + { "name" : "CLaSH.Sized.Internal.Signed.*#" , "templateE" : "resize(~ARG[1] * ~ARG[2], ~LIT[0])" } } @@ -748,65 +748,73 @@ is actually just like a @newtype@ wrapper for 'Integer'. The second kind of primitive that we will explore is the /declaration/ primitive. -We will use 'blockRam' as an example, for which the Haskell/CλaSH code is: +We will use 'cblockRam' as an example, for which the Haskell/CλaSH code is: @ -{\-# NOINLINE blockRam #-\} --- | Create a blockRAM with space for \@n\@ elements +{\-\# NOINLINE cblockRam \#-\} +-- | Create a blockRAM with space for @n@ elements -- --- NB: Read value is delayed by 1 cycle +-- * \_\_NB\_\_: Read value is delayed by 1 cycle +-- * \_\_NB\_\_: Initial output value is \'undefined\' -- --- > bram40 :: Signal (Unsigned 6) -> Signal (Unsigned 6) -> Signal Bool -> Signal a -> Signal a --- > bram40 = blockRam d40 -blockRam :: forall n m a . (KnownNat n, KnownNat m, Pack a, Default a) - => SNat n -- ^ Size \@n\@ of the blockram - -> Signal (Unsigned m) -- ^ Write address \@w\@ - -> Signal (Unsigned m) -- ^ Read address \@r\@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address \@w\@) - -> Signal a -- ^ Value of the 'blockRAM' at address \@r\@ from the previous clock cycle -blockRam n wr rd en din = pack $ (bram' \<^\> binit) (wr,rd,en,din) +-- > type ClkA = Clk \"A\" 100 +-- > +-- > clkA100 :: SClock ClkA +-- > clkA100 = sclock +-- > +-- > bram40 :: CSignal ClkA (Unsigned 6) -> CSignal ClkA (Unsigned 6) +-- > -> CSignal ClkA Bool -> CSignal ClkA Bit -> ClkA CSignal Bit +-- > bram40 = cblockRam clkA100 (replicate d40 H) +cblockRam :: (KnownNat n, KnownNat m) + => SClock clk -- ^ \'Clock\' to synchronize to + -> Vec n a -- ^ Initial content of the BRAM, also + -- determines the size, \@n\@, of the BRAM. + -- + -- \_\_NB\_\_: \_\_MUST\_\_ be a constant. + -> CSignal clk (Unsigned m) -- ^ Write address \@w\@ + -> CSignal clk (Unsigned m) -- ^ Read address \@r\@ + -> CSignal clk Bool -- ^ Write enable + -> CSignal clk a -- ^ Value to write (at address \@w\@) + -> CSignal clk a + -- ^ Value of the \'blockRAM\' at address \@r\@ from the previous clock + -- cycle +cblockRam clk binit wr rd en din = + cmealy clk bram' (binit,undefined) (bundle clk (wr,rd,en,din)) where - binit :: (Vec n a,a) - binit = (vcopy n def,def) - - bram' :: (Vec n a,a) -> (Unsigned m, Unsigned m, Bool, a) - -> (((Vec n a),a),a) bram' (ram,o) (w,r,e,d) = ((ram',o'),o) where - ram' | e = vreplace ram w d + ram' | e = replace ram w d | otherwise = ram - o' = ram ! r + o' = ram !! r @ And for which the /definition/ primitive is: @ { \"BlackBox\" : - { "name" : "CLaSH.Prelude.blockRam" - , "templateD" : -"~SYM[0]_block : block - type ram_array is array (natural range <>) of ~TYP[8]; - signal ~SYM[1] : ram_array((~ARG[0]-1) downto 0) := (others => ~ARG[3]); -- ram - signal ~SYM[2] : ~TYP[8]; -- inp - signal ~SYM[3] : ~TYP[8] := ~ARG[3]; -- outp + { "name" : "CLaSH.Prelude.BlockRam.cblockRam" + , "templateD" : +"blockram_~SYM[0] : block + signal ~SYM[1] : ~TYP[3] := ~LIT[3]; -- ram + signal ~SYM[2] : ~TYP[7]; -- inp + signal ~SYM[3] : ~TYP[7]; -- outp begin - ~SYM[2] <= ~ARG[8]; + ~SYM[2] <= ~ARG[7]; - process(~CLKO) + process(~CLK[2]) begin - if rising_edge(~CLKO) then - if ~ARG[7] then - ~SYM[1](to_integer(~ARG[5])) <= ~SYM[2]; + if rising_edge(~CLK[2]) then + if ~ARG[6] then + ~SYM[1](to_integer(~ARG[4])) <= ~SYM[2]; end if; - ~SYM[3] <= ~SYM[1](to_integer(~ARG[6])); + ~SYM[3] <= ~SYM[1](to_integer(~ARG[5])); end if; end process; ~RESULT <= ~SYM[3]; end block;" + } } -} @ Again, the @name@ of the primitive is the fully qualified name of the function @@ -873,18 +881,18 @@ ... = f a b (c,d) @ - add the 'pack' function like so: + add the 'bundle'' function like so: @ - ... = f a b (pack (c,d)) + ... = f a b (bundle' (c,d)) @ - Product types supported by 'pack' are: + Product types supported by 'bundle'' are: * All tuples until and including 8-tuples * The 'Vec'tor type - NB: Use 'cpack' when you are using explicitly clocked 'CSignal's + NB: Use 'bundle' when you are using explicitly clocked 'CSignal's * __Type error: Couldn't match expected type ‘(Signal a, Signal b)’ with__ __ actual type ‘Signal (a,b)’__: @@ -898,18 +906,18 @@ (c,d) = f a b @ - add the 'unpack' function like so: + add the 'unbundle'' function like so: @ - (c,d) = unpack (f a b) + (c,d) = unbundle' (f a b) @ - Product types supported by 'unpack' are: + Product types supported by 'unbundle'' are: * All tuples until and including 8-tuples * The 'Vec'tor type - NB: Use 'cunpack' when you are using explicitly clocked 'CSignal's + NB: Use 'unbundle' when you are using explicitly clocked 'CSignal's * __CLaSH.Netlist(..): Not in normal form: \: \__: @@ -982,30 +990,30 @@ @ -- Bubble sort for 1 iteration - sortV xs = vmap fst sorted <: (snd (vlast sorted)) + sortV xs = map fst sorted <: (snd (last sorted)) where - lefts = vhead xs :> vmap snd (vinit sorted) - rights = vtail xs - sorted = vzipWith compareSwapL lefts rights + lefts = head xs :> map snd (init sorted) + rights = tail xs + sorted = zipWith compareSwapL lefts rights -- Compare and swap compareSwapL a b = if a < b then (a,b) else (b,a) @ - Will not terminate because 'vzipWith' is too strict in its second argument: + Will not terminate because 'zipWith' is too strict in its second argument: >>> sortV (4 :> 1 :> 2 :> 3 :> Nil) <*** Exception: <> - In this case, adding 'lazyV' on 'vzipWith's second argument: + In this case, adding 'lazyV' on 'zipWith's second argument: @ - sortVL xs = vmap fst sorted <: (snd (vlast sorted)) + sortVL xs = map fst sorted <: (snd (last sorted)) where - lefts = vhead xs :> vmap snd (vinit sorted) - rights = vtail xs - sorted = vzipWith compareSwapL (lazyV lefts) rights + lefts = head xs :> map snd (init sorted) + rights = tail xs + sorted = zipWith compareSwapL ('lazyV' lefts) rights @ Results in a successful computation: @@ -1033,11 +1041,11 @@ is the following function that performs one iteration of bubble sort: @ - sortVL xs = vmap fst sorted <: (snd (vlast sorted)) + sortV xs = map fst sorted <: (snd (last sorted)) where - lefts = vhead xs :> vmap snd (vinit sorted) - rights = vtail xs - sorted = vzipWith compareSwapL (lazyV lefts) rights + lefts = head xs :> map snd (init sorted) + rights = tail xs + sorted = zipWith compareSwapL lefts rights @ Where we can clearly see that 'lefts' and 'sorted' are defined in terms of