diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) +## 0.11.1 *April 10th 2017* +* Changes: + * Bundle instance for `()` behaves like a product-type instance [#96](https://github.com/clash-lang/clash-prelude/issues/96) +* Fixes bugs: + * Ensure that `fold` gets correctly type-applied in `Vec.==` [#202](https://github.com/clash-lang/clash-compiler/issues/202) + ## 0.11 *January 16th 2017* * New features: * `CLaSH.XException`: a module defining an exception representing uninitialised values. Additionally adds the `ShowX` class which has methods that print values as "X" where they would normally raise an `XException` exception. 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.11 +Version: 0.11.1 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -86,6 +86,7 @@ ghc-options: -Wall -fexpose-all-unfoldings Exposed-modules: CLaSH.Annotations.TopEntity + CLaSH.Annotations.Primitive CLaSH.Class.BitPack CLaSH.Class.Num @@ -180,11 +181,13 @@ ghc-typelits-extra >= 0.2.1 && < 0.3, ghc-typelits-knownnat >= 0.2.2 && < 0.3, ghc-typelits-natnormalise >= 0.4.2 && < 0.6, + half >= 0.2.2.3 && < 1.0, lens >= 4.9 && < 4.16, QuickCheck >= 2.7 && < 2.10, reflection >= 2 && < 2.2, singletons >= 1.0 && < 3.0, - template-haskell >= 2.9.0.0 && < 2.12 + template-haskell >= 2.9.0.0 && < 2.12, + vector >= 0.11 && < 1.0 if flag(doclinks) CPP-Options: -DDOCLINKS diff --git a/src/CLaSH/Annotations/Primitive.hs b/src/CLaSH/Annotations/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/Annotations/Primitive.hs @@ -0,0 +1,25 @@ +{-| +Copyright : (C) 2017, QBayLogic +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module CLaSH.Annotations.Primitive where + +import Data.Data + +data HDL + = SystemVerilog + | Verilog + | VHDL + deriving (Eq, Show, Read, Data) + +data Primitive + = Primitive HDL FilePath + deriving (Show, Read, Data) diff --git a/src/CLaSH/Class/BitPack.hs b/src/CLaSH/Class/BitPack.hs --- a/src/CLaSH/Class/BitPack.hs +++ b/src/CLaSH/Class/BitPack.hs @@ -30,7 +30,9 @@ wordToFloat) import Data.Int import Data.Word +import Foreign.C.Types (CUShort) import GHC.TypeLits (KnownNat, Nat, type (+)) +import Numeric.Half (Half (..)) import Prelude hiding (map) import CLaSH.Class.Resize (zeroExtend) @@ -169,6 +171,16 @@ unpackDouble# = wordToDouble . fromInteger . unsafeToInteger {-# NOINLINE unpackDouble# #-} +instance BitPack CUShort where + type BitSize CUShort = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Half where + type BitSize Half = 16 + pack (Half x) = pack x + unpack x = Half (unpack x) + instance BitPack () where type BitSize () = 0 pack _ = minBound @@ -215,6 +227,17 @@ type BitSize (a,b,c,d,e,f,g,h) = BitSize (a,b,c,d,e,f,g) + BitSize h pack (a,b,c,d,e,f,g,h) = pack (a,b,c,d,e,f,g) ++# pack h unpack (unpack -> ((a,b,c,d,e,f,g), h)) = (a,b,c,d,e,f,g,h) + +instance (BitPack a, KnownNat (BitSize a)) => BitPack (Maybe a) where + type BitSize (Maybe a) = 1 + BitSize a + pack Nothing = low ++# 0 + -- We cannot do `low ++# undefined`, because `BitVector`s underlying + -- representation is `Integer`, so `low ++# undefined` would make the + -- entire `BitVector` undefined. + pack (Just x) = high ++# pack x + unpack x = case split# x of + (c,rest) | c == low -> Nothing + | otherwise -> Just (unpack rest) -- | Zero-extend a 'Bool'ean value to a 'BitVector' of the appropriate size. -- 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 @@ -50,7 +50,7 @@ = 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 + | SatSymmetric -- ^ Become 'maxBound' on overflow, and (@'minBound' + 1@) on -- underflow for signed numbers, and 'minBound' for unsigned -- numbers. deriving Eq diff --git a/src/CLaSH/Prelude/BlockRam.hs b/src/CLaSH/Prelude/BlockRam.hs --- a/src/CLaSH/Prelude/BlockRam.hs +++ b/src/CLaSH/Prelude/BlockRam.hs @@ -201,9 +201,10 @@ @ Again, we can simulate our system and see that it works. This time however, -we need to drop the first few output samples, because the initial content of an +we need to disregard the first few output samples, because the initial content of an 'CLaSH.Prelude.RAM.asyncRam' is 'undefined', and consequently, the first few -output samples are also 'undefined'. +output samples are also 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X" in the few leading outputs. @ >>> printX $ sampleN 31 $ system2 prog @@ -321,9 +322,9 @@ @ When we simulate our system we see that it works. This time again, -we need to drop the first sample, because the initial output of a -'blockRam' is 'undefined', and consequently, the first output sample is -also 'undefined'. +we need to disregard the first sample, because the initial output of a +'blockRam' is 'undefined'. We use the utility function 'printX' to conveniently +filter out the undefinedness and replace it with the string "X". @ >>> printX $ sampleN 33 $ system3 prog2 @@ -335,6 +336,7 @@ -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -345,6 +347,10 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} +-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c +-- as to why we need this. +{-# OPTIONS_GHC -fno-cpr-anal #-} + module CLaSH.Prelude.BlockRam ( -- * BlockRAM synchronised to the system clock blockRam @@ -360,22 +366,18 @@ ) where -import Control.Exception (catch, evaluate, throw) -import Control.Monad (when) -import Control.Monad.ST.Lazy (ST,runST) -import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) -import Data.Array.MArray.Safe (newListArray,readArray,writeArray) -import Data.Array.ST.Safe (STArray) import Data.Maybe (fromJust, isJust) +import qualified Data.Vector as V import GHC.TypeLits (KnownNat, type (^)) import Prelude hiding (length) import CLaSH.Signal (Signal, mux) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (bundle, unbundle) +import CLaSH.Signal.Explicit (SClock, register', systemClock) +import CLaSH.Signal.Internal (Signal' (..)) +import CLaSH.Signal.Bundle (unbundle) import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec, length, toList) -import CLaSH.XException (XException, errorX) +import CLaSH.Sized.Vector (Vec, toList) +import CLaSH.XException (errorX) {- $setup >>> import CLaSH.Prelude as C @@ -635,7 +637,7 @@ -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- Block RAM. -- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. -blockRam :: (KnownNat n, Enum addr) +blockRam :: Enum addr => Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. -- @@ -702,7 +704,7 @@ -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- Block RAM. -- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRam' clk inits) rd wrM@. -blockRam' :: (KnownNat n, Enum addr) +blockRam' :: Enum addr => SClock clk -- ^ 'Clock' to synchronize to -> Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. @@ -715,11 +717,9 @@ -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle blockRam' clk content rd wrM = - blockRam# clk content - (fromEnum <$> rd) - (isJust <$> wrM) - ((fromEnum . fst . fromJust) <$> wrM) - ((snd . fromJust) <$> wrM) + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in blockRam# clk content (fromEnum <$> rd) en (fromEnum <$> wr) din {-# INLINE blockRamPow2' #-} -- | Create a blockRAM with space for 2^@n@ elements @@ -760,8 +760,7 @@ blockRamPow2' = blockRam' -- | blockRAM primitive -blockRam# :: KnownNat n - => SClock clk -- ^ 'Clock' to synchronize to +blockRam# :: SClock clk -- ^ 'Clock' to synchronize to -> Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. -- @@ -773,26 +772,16 @@ -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle -blockRam# clk content rd en wr din = - register' clk (errorX "blockRam#: intial value undefined") dout +blockRam# _clk content = + go (V.fromList (toList content)) (errorX "blockRam#: intial value undefined") where - szI = length content - dout = runST $ do - arr <- newListArray (0,szI-1) (toList content) - traverse (ramT arr) (bundle (rd,en,wr,din)) + go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = ram V.! r + in o :- go ram' o' rs en wr din - ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e - ramT ram (r,e,w,d) = do - -- reading from address using an 'X' exception results in an 'X' result - r' <- unsafeIOToST $ - catch (evaluate r >>= (return . Right)) - (\(err :: XException) -> return (Left (throw err))) - d' <- case r' of - Right r2 -> readArray ram r2 - Left err -> return err - -- writing to an address using an 'X' exception makes everything 'X' - when e (writeArray ram w d) - return d' + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram {-# NOINLINE blockRam# #-} -- | Create read-after-write blockRAM from a read-before-write one (synchronised to specified clock) diff --git a/src/CLaSH/Prelude/BlockRam/File.hs b/src/CLaSH/Prelude/BlockRam/File.hs --- a/src/CLaSH/Prelude/BlockRam/File.hs +++ b/src/CLaSH/Prelude/BlockRam/File.hs @@ -63,6 +63,7 @@ -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -74,6 +75,10 @@ {-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} +-- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c +-- as to why we need this. +{-# OPTIONS_GHC -fno-cpr-anal #-} + module CLaSH.Prelude.BlockRam.File ( -- * BlockRAM synchronised to the system clock blockRamFile @@ -87,24 +92,21 @@ ) where -import Control.Exception (catch, evaluate, throw) -import Control.Monad (when) -import Control.Monad.ST.Lazy (ST,runST) -import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) -import Data.Array.MArray (newListArray,readArray,writeArray) -import Data.Array.ST (STArray) import Data.Char (digitToInt) import Data.Maybe (fromJust, isJust, listToMaybe) +import qualified Data.Vector as V import GHC.TypeLits (KnownNat) import Numeric (readInt) +import System.IO.Unsafe (unsafePerformIO) -import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) +import CLaSH.Promoted.Nat (SNat (..), pow2SNat) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Signal (Signal) -import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (bundle) +import CLaSH.Signal.Explicit (SClock, systemClock) +import CLaSH.Signal.Internal (Signal' (..)) +import CLaSH.Signal.Bundle (unbundle) import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (XException, errorX) +import CLaSH.XException (errorX) {-# INLINE blockRamFile #-} -- | Create a blockRAM with space for @n@ elements @@ -177,7 +179,7 @@ -- content of the blockRAM -> Signal (Unsigned n) -- ^ Read address @r@ -> Signal (Maybe (Unsigned n, BitVector m)) - -- ^ (write address @w@, value to write)@) + -- ^ (write address @w@, value to write) -> Signal (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle @@ -261,13 +263,10 @@ -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle blockRamFile' clk sz file rd wrM = - blockRamFile# clk sz file - (fromEnum <$> rd) - (isJust <$> wrM) - ((fromEnum . fst . fromJust) <$> wrM) - ((snd . fromJust) <$> wrM) + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in blockRamFile# clk sz file (fromEnum <$> rd) en (fromEnum <$> wr) din -{-# NOINLINE blockRamFile# #-} -- | blockRamFile primitive blockRamFile# :: KnownNat m => SClock clk -- ^ 'Clock' to synchronize to @@ -281,25 +280,20 @@ -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle -blockRamFile# clk sz file rd en wr din = register' clk (errorX "blockRamFile#: intial value undefined") dout +blockRamFile# _clk _sz file = + go ramI (errorX "blockRamFile#: intial value undefined") where - szI = snatToNum sz - dout = runST $ do - mem <- unsafeIOToST (initMem file) - arr <- newListArray (0,szI-1) mem - traverse (ramT arr) (bundle (rd,en,wr,din)) + go !ram o (r :- rs) (e :- en) (w :- wr) (d :- din) = + let ram' = upd ram e w d + o' = ram V.! r + in o :- go ram' o' rs en wr din - ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e - ramT ram (r,e,w,d) = do - -- reading from address using an 'X' exception results in an 'X' result - r' <- unsafeIOToST (catch (evaluate r >>= (return . Right)) - (\(err :: XException) -> return (Left (throw err)))) - d' <- case r' of - Right r2 -> readArray ram r2 - Left err -> return err - -- writing to an address using an 'X' exception makes everything 'X' - when e (writeArray ram w d) - return d' + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram + + content = unsafePerformIO (initMem file) + ramI = V.fromList content +{-# NOINLINE blockRamFile# #-} {-# NOINLINE initMem #-} -- | __NB:__ Not synthesisable diff --git a/src/CLaSH/Prelude/RAM.hs b/src/CLaSH/Prelude/RAM.hs --- a/src/CLaSH/Prelude/RAM.hs +++ b/src/CLaSH/Prelude/RAM.hs @@ -6,6 +6,7 @@ RAM primitives with a combinational read port. -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -35,21 +36,17 @@ ) where -import Control.Exception (catch, evaluate, throw) -import Control.Monad (when) -import Control.Monad.ST.Lazy (ST,runST) -import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) -import Data.Array.MArray.Safe (newListArray,readArray,writeArray) -import Data.Array.ST.Safe (STArray) import Data.Maybe (fromJust, isJust) import GHC.TypeLits (KnownNat) +import qualified Data.Vector as V import CLaSH.Promoted.Nat (SNat (..), snatToNum, pow2SNat) import CLaSH.Signal (Signal) -import CLaSH.Signal.Bundle (bundle) -import CLaSH.Signal.Explicit (Signal', SClock, systemClock, unsafeSynchronizer) +import CLaSH.Signal.Bundle (unbundle) +import CLaSH.Signal.Explicit (SClock, systemClock, unsafeSynchronizer) +import CLaSH.Signal.Internal (Signal' (..)) import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.XException (XException, errorX) +import CLaSH.XException (errorX) {-# INLINE asyncRam #-} -- | Create a RAM with space for @n@ elements. @@ -127,14 +124,10 @@ -- ^ (write address @w@, value to write) -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ asyncRam' wclk rclk sz rd wrM = - asyncRam# wclk rclk sz - (fromEnum <$> rd) - (isJust <$> wrM) - ((fromEnum . fst . fromJust) <$> wrM) - ((snd . fromJust) <$> wrM) - + let en = isJust <$> wrM + (wr,din) = unbundle (fromJust <$> wrM) + in asyncRam# wclk rclk sz (fromEnum <$> rd) en (fromEnum <$> wr) din -{-# NOINLINE asyncRam# #-} -- | RAM primitive asyncRam# :: SClock wclk -- ^ 'Clock' to which to synchronise the write -- port of the RAM @@ -148,20 +141,17 @@ -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ asyncRam# wclk rclk sz rd en wr din = unsafeSynchronizer wclk rclk dout where - szI = snatToNum sz rd' = unsafeSynchronizer rclk wclk rd - dout = runST $ do - arr <- newListArray (0,szI-1) (replicate szI (errorX "asyncRam#: initial value undefined")) - traverse (ramT arr) (bundle (rd',en,wr,din)) + ramI = V.replicate (snatToNum sz) (errorX "asyncRam#: initial value undefined") + dout = go ramI rd' en wr din - ramT :: STArray s Int e -> (Int,Bool,Int,e) -> ST s e - ramT ram (r,e,w,d) = do - -- reading from address using an 'X' exception results in an 'X' result - r' <- unsafeIOToST (catch (evaluate r >>= (return . Right)) - (\(err :: XException) -> return (Left (throw err)))) - d' <- case r' of - Right r2 -> readArray ram r2 - Left err -> return err - -- writing to an address using an 'X' exception makes everything 'X' - when e (writeArray ram w d) - return d' + go :: V.Vector a -> Signal' wclk Int -> Signal' wclk Bool + -> Signal' wclk Int -> Signal' wclk a -> Signal' wclk a + go !ram (r :- rs) (e :- es) (w :- ws) (d :- ds) = + let ram' = upd ram e w d + o = ram V.! r + in o :- go ram' rs es ws ds + + upd ram True addr d = ram V.// [(addr,d)] + upd ram False _ _ = ram +{-# NOINLINE asyncRam# #-} diff --git a/src/CLaSH/Signal/Bundle.hs b/src/CLaSH/Signal/Bundle.hs --- a/src/CLaSH/Signal/Bundle.hs +++ b/src/CLaSH/Signal/Bundle.hs @@ -12,6 +12,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} @@ -26,6 +27,7 @@ import GHC.TypeLits (KnownNat) import Prelude hiding (head, map, tail) +import CLaSH.NamedTypes ((:::)) import CLaSH.Signal.Internal (Clock, Signal' (..)) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Fixed (Fixed) @@ -106,7 +108,6 @@ instance Bundle Int instance Bundle Float instance Bundle Double -instance Bundle () instance Bundle (Maybe a) instance Bundle (Either a b) @@ -115,6 +116,16 @@ instance Bundle (Fixed rep int frac) instance Bundle (Signed n) instance Bundle (Unsigned n) + +-- | Note that: +-- +-- > bundle :: () -> Signal' clk () +-- > unbundle :: Signal' clk () -> () +instance Bundle () where + type Unbundled' t () = t ::: () + -- ^ This is just to satisfy the injectivity annotation + bundle u = pure u + unbundle _ = () instance Bundle (a,b) where type Unbundled' t (a,b) = (Signal' t a, Signal' t b) diff --git a/src/CLaSH/Signal/Internal.hs b/src/CLaSH/Signal/Internal.hs --- a/src/CLaSH/Signal/Internal.hs +++ b/src/CLaSH/Signal/Internal.hs @@ -100,7 +100,7 @@ import CLaSH.Promoted.Nat (SNat, snatToInteger) import CLaSH.Promoted.Symbol (SSymbol, ssymbolToString) -import CLaSH.XException (XException, errorX) +import CLaSH.XException (XException, errorX, seqX) {- $setup >>> :set -XDataKinds @@ -267,10 +267,10 @@ {-# NOINLINE regEn# #-} regEn# :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a -regEn# clk i b s = r +regEn# _ = go where - r = register# clk i s' - s' = mux b s r + go o (e :- es) as@(~(x :- xs)) = + o `seqX` o :- (as `seq` if e then go x es xs else go o es xs) {-# INLINE mux #-} -- | The above type is a generalisation for: diff --git a/src/CLaSH/Sized/Internal/BitVector.hs b/src/CLaSH/Sized/Internal/BitVector.hs --- a/src/CLaSH/Sized/Internal/BitVector.hs +++ b/src/CLaSH/Sized/Internal/BitVector.hs @@ -575,6 +575,8 @@ instance Resize BitVector where resize = resize# zeroExtend = extend + signExtend = \ bv -> (case msb# bv of 0 -> id + 1 -> complement) 0 ++# bv truncateB = resize# {-# NOINLINE resize# #-} 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 @@ -246,7 +246,7 @@ instance (KnownNat n, Eq a) => Eq (Vec n a) where (==) v1 v2 | length v1 == 0 = True - | otherwise = fold (&&) (unsafeCoerce (zipWith (==) v1 v2)) + | otherwise = fold @Bool @n (&&) (unsafeCoerce (zipWith (==) v1 v2)) -- FIXME: the `unsafeCoerce` is a hack because the CLaSH compiler cannot deal -- with the existential length of the 'xs' in "Cons x xs". -- diff --git a/src/CLaSH/Tutorial.hs b/src/CLaSH/Tutorial.hs --- a/src/CLaSH/Tutorial.hs +++ b/src/CLaSH/Tutorial.hs @@ -1391,9 +1391,9 @@ @ We see that we give it @2^addrSize@ elements, where @addrSize@ is the bit-size -of the address. Also, we only write new values to the ram when a new write is -requested, indicated by @winc@, and the buffer is not full, indicated by -@wfull@. +of the address. Also, we only write new values to the RAM when a new write is +requested, indicated by @wdataM@ having a $Just$ value, and the buffer is not +full, indicated by @wfull@. The next part of the design calculates the read and write address for the asynchronous RAM, and creates the flags indicating whether the FIFO is full @@ -1427,7 +1427,7 @@ isEmpty = (==) rptrEmptyInit = (0,0,True) --- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} +-- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} isFull addrSize ptr s_ptr = ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' 'slice' (addrSize ``subSNat`` d2) d0 s_ptr @@ -1515,14 +1515,14 @@ isEmpty = (==) rptrEmptyInit = (0,0,True) --- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} +-- FIFO full: when next pntr == synchronized {~wptr[addrSize:addrSize-1],wptr[addrSize-2:0]} isFull addrSize ptr s_ptr = ptr == 'complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' 'slice' (addrSize ``subSNat`` d2) d0 s_ptr wptrFullInit = (0,0,False) --- Dual flip-flip synchroniser +-- Dual flip-flop synchroniser ptrSync clk1 clk2 = 'register'' clk2 0 . 'register'' clk2 0 . 'unsafeSynchronizer' clk1 clk2 diff --git a/src/CLaSH/XException.hs b/src/CLaSH/XException.hs --- a/src/CLaSH/XException.hs +++ b/src/CLaSH/XException.hs @@ -1,5 +1,5 @@ {-| -Copyright : (C) 2016, University of Twente +Copyright : (C) 2016, University of Twente, 2017, QBayLogic License : BSD2 (see the file LICENSE) Maintainer : Christiaan Baaij @@ -30,7 +30,10 @@ ( -- * 'X': An exception for uninitialized values XException, errorX -- * Printing 'X' exceptions as \"X\" - , ShowX (..), showsX, printX, showsPrecXWith) + , ShowX (..), showsX, printX, showsPrecXWith + -- * Strict evaluation + , seqX + ) where import Control.Exception (Exception, catch, evaluate, throw) @@ -58,6 +61,20 @@ -- out with an exception. errorX :: HasCallStack => String -> a errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack)) + +-- | Like 'seq', however, whereas 'seq' will always do: +-- +-- > seq _|_ b = _|_ +-- +-- 'seqX' will do: +-- +-- > seqX (XException msg) b = b +-- > seqX _|_ b = _|_ +seqX :: a -> b -> b +seqX a b = unsafeDupablePerformIO + (catch (evaluate a >> return b) (\(XException _) -> return b)) +{-# NOINLINE seqX #-} +infixr 0 `seqX` showXWith :: (a -> ShowS) -> a -> ShowS showXWith f x =