diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,24 @@ # Changelog for [`clash-prelude` package](http://hackage.haskell.org/package/clash-prelude) -## 0.10.14 *August 21st 2016* -* Build against ghc-typelits-extra-0.2 - -## 0.10.13 *August 18th 2016* +## 0.11 *January 16th 2017* * New features: - * Thanks to Joe Hermaszewski (@expipiplus1): Add an explicitly clocked `DSignal` - * Add a `Real` instance for `Fixed` [#158](https://github.com/clash-lang/clash-compiler/issues/158) -* Fixes bugs: - * {BitVector;Index;Signed;Unsigned} `enumFromTo` and friends overflowed on values outside `Int` range [#166](https://github.com/clash-lang/clash-compiler/issues/166) + * `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. + * Add `BNat` (and supporting functions) to `CLaSH.Promoted.Nat`: base-2 encoded natural numbers. + * Add `divSNat` and `logBaseSNat` to `CLaSH.Promoted.Nat`: division and logarithm for singleton natural numbers. + * Add `predUNat` and `subUNat` to `CLaSH.Promoted.Nat`: predecessor and subtraction for unary-encoded natural numbers. + * Add `dtfold` to `CLaSH.Sized.Vector`: a dependently-typed tree-fold over `Vec`. + * Add the perfect-depth binary trees module `CLaSH.Sized.RTree` + * Synthesisable definitions of `countLeadingZeros` and `countTrailingZeros` for: `BitVector`, `Signed`, `Unsigned`, and `Fixed` + * Add the `(:::)` type alias in `CLaSH.NamedTypes` which allows you to annotate types with documentation +* Changes: + * `asyncRam`, `blockRam`, `blockRamFile` have a `Maybe (addr,a)` as write input instead of three separate `Bool`, `addr`, and `a` inputs. + * `asyncFIFOSynchronizer` has a `Maybe a` as write-request instead of a separate `Bool` and `a` input + * `bundle'` and `unbundle'` are removed; `bundle` now has type `Unbundled' clk a -> Signal' clk a`, `unbundle` now has type `Signal' clk a -> Unbundled' clk a` + * `subSNat` now has the type `SNat (a+b) -> SNat b -> SNat a` (where it used to be `SNat a -> SNat b -> SNat (a-b)`) + * Renamed `multUNat` to `mulUNat` to be in sync with `mulSNat` and `mulBNat`. + * The function argument of `vfold` in `CLaSH.Sized.Vector` is now `(forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b)` (where it used to be `(forall l . a -> Vec l b -> Vec (l + 1) b)`) + * `Cons` constructor of `Vec` is no longer visible; `(:>)` and `(:<)` are now listed as constructors of `Vec` + * Simulation speed improvements for numeric types ## 0.10.12 * Fixes bugs: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright (c) 2013-2016, University of Twente +Copyright (c) 2013-2016, University of Twente, + 2017, QBayLogic All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,11 +1,11 @@ # CλaSH - A functional hardware description language -[![Build Status](https://travis-ci.org/clash-lang/clash-prelude.svg?branch=0.10)](https://travis-ci.org/clash-lang/clash-prelude?branch=0.10) +[![Build Status](https://travis-ci.org/clash-lang/clash-prelude.svg?branch=master)](https://travis-ci.org/clash-lang/clash-prelude) [![Hackage](https://img.shields.io/hackage/v/clash-prelude.svg)](https://hackage.haskell.org/package/clash-prelude) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/clash-prelude.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=exact%3Aclash-prelude) __WARNING__ -Only works with GHC-7.10.* (http://www.haskell.org/ghc/download_ghc_7_10_3)! +Only works with GHC-8.0.* (http://www.haskell.org/ghc/download_ghc_8_0_2)! CλaSH (pronounced ‘clash’) is a functional hardware description language that borrows both its syntax and semantics from the functional programming language @@ -14,9 +14,8 @@ Features of CλaSH: - * Strongly typed (like VHDL), yet with a very high degree of type inference, - enabling both safe and fast prototying using consise descriptions (like - Verilog). + * Strongly typed, yet with a very high degree of type inference, enabling both + safe and fast prototyping using concise descriptions. * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. diff --git a/benchmarks/BenchBitVector.hs b/benchmarks/BenchBitVector.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchBitVector.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} + +{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} + +#define WORD_SIZE_IN_BITS 64 + +module BenchBitVector where + +import CLaSH.Sized.Internal.BitVector +import CLaSH.Class.Num +import GHC.TypeLits (type (*)) +import Criterion (Benchmark, env, bench, nf) +import Language.Haskell.TH.Syntax (lift) + +smallValue1 :: BitVector WORD_SIZE_IN_BITS +smallValue1 = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) +{-# INLINE smallValue1 #-} + +smallValue2 :: BitVector WORD_SIZE_IN_BITS +smallValue2 = $(lift (2^(16::Int)-100 :: BitVector WORD_SIZE_IN_BITS)) +{-# INLINE smallValue2 #-} + +largeValue1 :: BitVector (3*WORD_SIZE_IN_BITS) +largeValue1 = 2^(2*WORD_SIZE_IN_BITS :: Int)-10 :: BitVector (3*WORD_SIZE_IN_BITS) +{-# INLINE largeValue1 #-} + +largeValue2 :: BitVector (3*WORD_SIZE_IN_BITS) +largeValue2 = 2^(2*WORD_SIZE_IN_BITS :: Int)-100 :: BitVector (3*WORD_SIZE_IN_BITS) +{-# INLINE largeValue2 #-} + +addBench :: Benchmark +addBench = env setup $ \m -> + bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m + where + setup = return (smallValue1,smallValue2) + +negateBench :: Benchmark +negateBench = env setup $ \m -> + bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m + where + setup = return smallValue1 + +subBench :: Benchmark +subBench = env setup $ \m -> + bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m + where + setup = return (smallValue1,smallValue2) + +multBench :: Benchmark +multBench = env setup $ \m -> + bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m + where + setup = return (smallValue1,smallValue2) + +plusBench :: Benchmark +plusBench = env setup $ \m -> + bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m + where + setup = return (smallValue1,smallValue2) + +minusBench :: Benchmark +minusBench = env setup $ \m -> + bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m + where + setup = return (smallValue1,smallValue2) + +timesBench :: Benchmark +timesBench = env setup $ \m -> + bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m + where + setup = return (smallValue1,smallValue2) + +boundedPlusBench :: Benchmark +boundedPlusBench = env setup $ \m -> + bench "boundedPlus WORD_SIZE_IN_BITS" $ nf (uncurry (boundedPlus)) m + where + setup = return (smallValue1,smallValue2) + +boundedMinBench :: Benchmark +boundedMinBench = env setup $ \m -> + bench "boundedMin WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMin)) m + where + setup = return (smallValue1,smallValue2) + +boundedMultBench :: Benchmark +boundedMultBench = env setup $ \m -> + bench "boundedMult WORD_SIZE_IN_BITS" $ nf (uncurry (boundedMult)) m + where + setup = return (smallValue1,smallValue2) + +msbBench :: Benchmark +msbBench = env setup $ \m -> + bench "msb# WORD_SIZE_IN_BITS" $ nf msb# m + where + setup = return smallValue1 + +msbBenchL :: Benchmark +msbBenchL = env setup $ \m -> + bench "msb# (3*WORD_SIZE_IN_BITS)" $ nf msb# m + where + setup = return largeValue1 + +appendBench :: Benchmark +appendBench = env setup $ \m -> + bench "++# WORD_SIZE_IN_BITS" $ nf (uncurry (++#)) m + where + setup = return (smallValue1,smallValue2) + +appendBenchL :: Benchmark +appendBenchL = env setup $ \m -> + bench "++# (3*WORD_SIZE_IN_BITS)" $ nf (uncurry (++#)) m + where + setup = return (largeValue1,largeValue2) + +splitBench :: Benchmark +splitBench = env setup $ \m -> + bench "split# WORD_SIZE_IN_BITS" $ nf (split# :: BitVector WORD_SIZE_IN_BITS -> (BitVector 18, BitVector 46)) m + where + setup = return smallValue1 + +splitBenchL :: Benchmark +splitBenchL = env setup $ \m -> + bench "split# (3*WORD_SIZE_IN_BITS)" $ nf (split# :: BitVector (3*WORD_SIZE_IN_BITS) -> (BitVector 18, BitVector 174)) m + where + setup = return largeValue1 diff --git a/benchmarks/BenchFixed.hs b/benchmarks/BenchFixed.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchFixed.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} + +{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} + +#define WORD_SIZE_IN_BITS 64 + +module BenchFixed where + +import CLaSH.Class.Num +import CLaSH.Sized.Fixed +import CLaSH.Sized.Unsigned +import Criterion (Benchmark, env, bench, nf) +import Language.Haskell.TH.Syntax (lift) + +smallValueR_pos :: Rational +smallValueR_pos = $(lift (5126.889117 :: Rational)) +{-# INLINE smallValueR_pos #-} + +smallValueU1 :: UFixed 24 17 +smallValueU1 = $(lift (5126.889117 :: UFixed 24 17)) +{-# INLINE smallValueU1 #-} + +smallValueU2 :: UFixed 24 17 +smallValueU2 = $(lift (56.589117 :: UFixed 24 17)) +{-# INLINE smallValueU2 #-} + +fromRationalBench :: Benchmark +fromRationalBench = env setup $ \m -> + bench "fromRational" $ nf (fromRational :: Rational -> UFixed 24 17) m + where + setup = return smallValueR_pos + +addBench :: Benchmark +addBench = env setup $ \m -> + bench "+" $ nf (uncurry (+)) m + where + setup = return (smallValueU1,smallValueU2) + +subBench :: Benchmark +subBench = env setup $ \m -> + bench "-" $ nf (uncurry (-)) m + where + setup = return (smallValueU1,smallValueU2) + +multBench :: Benchmark +multBench = env setup $ \m -> + bench "*" $ nf (uncurry (*)) m + where + setup = return (smallValueU1,smallValueU2) + +multBench_wrap :: Benchmark +multBench_wrap = env setup $ \m -> + bench "satMult SatWrap" $ nf (uncurry (satMult SatWrap)) m + where + setup = return (smallValueU1,smallValueU2) diff --git a/benchmarks/BenchSigned.hs b/benchmarks/BenchSigned.hs new file mode 100644 --- /dev/null +++ b/benchmarks/BenchSigned.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE CPP, DataKinds, MagicHash, TypeOperators, TemplateHaskell #-} + +{-# OPTIONS_GHC -ddump-simpl -ddump-splices -ddump-to-file #-} + +#define WORD_SIZE_IN_BITS 64 + +module BenchSigned where + +import CLaSH.Sized.BitVector +import CLaSH.Sized.Internal.Signed +import Criterion (Benchmark, env, bench, nf) +import Language.Haskell.TH.Syntax (lift) + +smallValueI_pos :: Integer +smallValueI_pos = $(lift (2^(16::Int)-10 :: Integer)) +{-# INLINE smallValueI_pos #-} + +smallValue_pos1 :: Signed WORD_SIZE_IN_BITS +smallValue_pos1 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS)) +{-# INLINE smallValue_pos1 #-} + +smallValue_pos2 :: Signed WORD_SIZE_IN_BITS +smallValue_pos2 = $(lift (2^(16::Int)-100 :: Signed WORD_SIZE_IN_BITS)) +{-# INLINE smallValue_pos2 #-} + +smallValueBV :: BitVector WORD_SIZE_IN_BITS +smallValueBV = $(lift (2^(16::Int)-10 :: BitVector WORD_SIZE_IN_BITS)) +{-# INLINE smallValueBV #-} + +addBench :: Benchmark +addBench = env setup $ \m -> + bench "+# WORD_SIZE_IN_BITS" $ nf (uncurry (+#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +negateBench :: Benchmark +negateBench = env setup $ \m -> + bench "negate# WORD_SIZE_IN_BITS" $ nf negate# m + where + setup = return smallValue_pos1 + +absBench :: Benchmark +absBench = env setup $ \m -> + bench "abs# WORD_SIZE_IN_BITS" $ nf abs# m + where + setup = return smallValue_pos1 + +subBench :: Benchmark +subBench = env setup $ \m -> + bench "-# WORD_SIZE_IN_BITS" $ nf (uncurry (-#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +multBench :: Benchmark +multBench = env setup $ \m -> + bench "*# WORD_SIZE_IN_BITS" $ nf (uncurry (*#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +plusBench :: Benchmark +plusBench = env setup $ \m -> + bench "plus# WORD_SIZE_IN_BITS" $ nf (uncurry (plus#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +minusBench :: Benchmark +minusBench = env setup $ \m -> + bench "minus# WORD_SIZE_IN_BITS" $ nf (uncurry (minus#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +timesBench :: Benchmark +timesBench = env setup $ \m -> + bench "times# WORD_SIZE_IN_BITS" $ nf (uncurry (times#)) m + where + setup = return (smallValue_pos1,smallValue_pos2) + +fromIntegerBench :: Benchmark +fromIntegerBench = env setup $ \m -> + bench "fromInteger# WORD_SIZE_IN_BITS" $ nf (fromInteger# :: Integer -> Signed WORD_SIZE_IN_BITS) m + where + setup = return smallValueI_pos + +packBench :: Benchmark +packBench = env setup $ \m -> + bench "pack# WORD_SIZE_IN_BITS" $ nf pack# m + where + setup = return smallValue_pos1 + +unpackBench :: Benchmark +unpackBench = env setup $ \m -> + bench "unpack# WORD_SIZE_IN_BITS" $ nf unpack# m + where + setup = return smallValueBV diff --git a/benchmarks/benchmark-main.hs b/benchmarks/benchmark-main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/benchmark-main.hs @@ -0,0 +1,51 @@ +module Main where + +import Criterion.Main + +import qualified BenchBitVector as BV +import qualified BenchFixed as F +import qualified BenchSigned as S + +main :: IO () +main = + defaultMain + [ + bgroup "BitVector" + [ BV.addBench + , BV.negateBench + , BV.subBench + , BV.multBench + , BV.plusBench + , BV.minusBench + , BV.timesBench + , BV.boundedPlusBench + , BV.boundedMinBench + , BV.boundedMultBench + , BV.msbBench + , BV.msbBenchL + , BV.appendBench + , BV.appendBenchL + , BV.splitBench + , BV.splitBenchL + ] + , bgroup "Signed" + [ S.fromIntegerBench + , S.addBench + , S.negateBench + , S.absBench + , S.subBench + , S.multBench + , S.plusBench + , S.minusBench + , S.timesBench + , S.packBench + , S.unpackBench + ] + , bgroup "Fixed" + [ F.fromRationalBench + , F.addBench + , F.subBench + , F.multBench + , F.multBench_wrap + ] + ] 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.10.14 +Version: 0.11 Synopsis: CAES Language for Synchronous Hardware - Prelude library Description: CλaSH (pronounced ‘clash’) is a functional hardware description language that @@ -9,9 +9,8 @@ . Features of CλaSH: . - * Strongly typed (like VHDL), yet with a very high degree of type inference, - enabling both safe and fast prototying using consise descriptions (like - Verilog). + * Strongly typed, but with a very high degree of type inference, enabling both + safe and fast prototyping using concise descriptions. . * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. @@ -45,7 +44,8 @@ License-file: LICENSE Author: Christiaan Baaij Maintainer: Christiaan Baaij -Copyright: Copyright © 2013-2016 University of Twente +Copyright: Copyright © 2013-2016, University of Twente, + 2017, QBayLogic Category: Hardware Build-type: Simple @@ -67,6 +67,12 @@ default: True manual: True +flag benchmarks + description: + You can disable testing with benchmarks using `-f-benchmarks`. + default: True + manual: True + flag doclinks description: Create hyperlinks to non-dependent packages using `-fdoclinks`. @@ -85,6 +91,8 @@ CLaSH.Class.Num CLaSH.Class.Resize + CLaSH.NamedTypes + CLaSH.Prelude CLaSH.Prelude.BitIndex CLaSH.Prelude.BitReduction @@ -106,7 +114,6 @@ CLaSH.Promoted.Nat.Literals CLaSH.Promoted.Nat.TH CLaSH.Promoted.Nat.Unsafe - CLaSH.Promoted.Ord CLaSH.Promoted.Symbol CLaSH.Signal @@ -129,54 +136,56 @@ CLaSH.Sized.Internal.Signed CLaSH.Sized.Internal.Unsigned + CLaSH.XException + CLaSH.Tutorial CLaSH.Examples - other-extensions: BangPatterns - DataKinds + other-extensions: CPP + BangPatterns ConstraintKinds + DataKinds DefaultSignatures - DeriveTraversable DeriveDataTypeable + DeriveTraversable + DeriveLift FlexibleContexts + FlexibleInstances GADTs GeneralizedNewtypeDeriving + InstanceSigs KindSignatures MagicHash MultiParamTypeClasses + PatternSynonyms Rank2Types ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections + TypeApplications TypeFamilies TypeOperators UndecidableInstances + ViewPatterns Build-depends: array >= 0.5.1.0 && < 0.6, base >= 4.8.0.0 && < 5, + constraints >= 0.8 && < 1.0, + data-binary-ieee754 >= 0.4.4 && < 0.6, data-default >= 0.5.3 && < 0.8, integer-gmp >= 0.5.1.0 && < 1.1, deepseq >= 1.4.1.0 && < 1.5, ghc-prim >= 0.3.1.0 && < 0.6, - ghc-typelits-extra >= 0.1 && < 0.3, - ghc-typelits-natnormalise >= 0.4.1 && < 0.6, - lens >= 4.9 && < 4.15, + ghc-typelits-extra >= 0.2.1 && < 0.3, + ghc-typelits-knownnat >= 0.2.2 && < 0.3, + ghc-typelits-natnormalise >= 0.4.2 && < 0.6, + 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 - if impl(ghc<7.11) - -- Newer GHCs have -XDeriveLift - Build-depends: th-lift >= 0.5.6 - -- Newer GHCs have a -fno-cpr-anal dynflag which we can enable per module - -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c - -- as to why we need this. - ghc-options: -fcpr-off - else - other-extensions: DeriveLift - if flag(doclinks) CPP-Options: -DDOCLINKS build-depends: transformers >= 0.4.2.0 @@ -194,3 +203,24 @@ build-depends: base >= 4 && < 5, doctest >= 0.9.1 && < 0.12 + +benchmark benchmark-clash-prelude + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: benchmark-main.hs + ghc-options: -O2 -Wall + hs-source-dirs: benchmarks + + if !flag(benchmarks) + buildable: False + else + build-depends: + base >= 4 && < 5, + clash-prelude, + criterion >= 1.1.1.0 && < 1.2, + deepseq >= 1.4.0.1 && < 1.5, + template-haskell >= 2.9.0.0 && < 2.12 + + Other-Modules: BenchBitVector + BenchFixed + BenchSigned diff --git a/src/CLaSH/Annotations/TopEntity.hs b/src/CLaSH/Annotations/TopEntity.hs --- a/src/CLaSH/Annotations/TopEntity.hs +++ b/src/CLaSH/Annotations/TopEntity.hs @@ -215,7 +215,7 @@ -- * __SystemVerilog__: @logic [n-1:0]@ , t_clocks :: [ClockSource] -- ^ List of clock sources } - deriving (Data,Show) + deriving (Data,Show,Read) -- | A clock source data ClockSource @@ -259,7 +259,7 @@ -- When 'c_sync' is set to 'True' those reset synchronisers are not generated -- and there is change for reset-induced metastability. } - deriving (Data,Show) + deriving (Data,Show,Read) -- | Default 'TopEntity' which has no clocks, and no specified names for the -- input and output ports. Also has no clock sources: 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 @@ -4,8 +4,8 @@ Maintainer : Christiaan Baaij -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -14,8 +14,11 @@ {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} +#include "MachDeps.h" + module CLaSH.Class.BitPack ( BitPack (..) , bitCoerce @@ -23,12 +26,16 @@ ) where +import Data.Binary.IEEE754 (doubleToWord, floatToWord, wordToDouble, + wordToFloat) +import Data.Int +import Data.Word import GHC.TypeLits (KnownNat, Nat, type (+)) import Prelude hiding (map) import CLaSH.Class.Resize (zeroExtend) import CLaSH.Sized.BitVector (BitVector, (++#), high, low) -import CLaSH.Sized.Internal.BitVector (split#) +import CLaSH.Sized.Internal.BitVector (unsafeToInteger, split#) {- $setup >>> :set -XDataKinds @@ -82,6 +89,91 @@ pack v = v unpack v = v +instance BitPack Int where + type BitSize Int = WORD_SIZE_IN_BITS + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int8 where + type BitSize Int8 = 8 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int16 where + type BitSize Int16 = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Int32 where + type BitSize Int32 = 32 + pack = fromIntegral + unpack = fromIntegral + +#if WORD_SIZE_IN_BITS >= 64 +instance BitPack Int64 where + type BitSize Int64 = 64 + pack = fromIntegral + unpack = fromIntegral +#endif + +instance BitPack Word where + type BitSize Word = WORD_SIZE_IN_BITS + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word8 where + type BitSize Word8 = 8 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word16 where + type BitSize Word16 = 16 + pack = fromIntegral + unpack = fromIntegral + +instance BitPack Word32 where + type BitSize Word32 = 32 + pack = fromIntegral + unpack = fromIntegral + +#if WORD_SIZE_IN_BITS >= 64 +instance BitPack Word64 where + type BitSize Word64 = 64 + pack = fromIntegral + unpack = fromIntegral +#endif + +instance BitPack Float where + type BitSize Float = 32 + pack = packFloat# + unpack = unpackFloat# + +packFloat# :: Float -> BitVector 32 +packFloat# = fromIntegral . floatToWord +{-# NOINLINE packFloat# #-} + +unpackFloat# :: BitVector 32 -> Float +unpackFloat# = wordToFloat . fromInteger . unsafeToInteger +{-# NOINLINE unpackFloat# #-} + +instance BitPack Double where + type BitSize Double = 64 + pack = packDouble# + unpack = unpackDouble# + +packDouble# :: Double -> BitVector 64 +packDouble# = fromIntegral . doubleToWord +{-# NOINLINE packDouble# #-} + +unpackDouble# :: BitVector 64 -> Double +unpackDouble# = wordToDouble . fromInteger . unsafeToInteger +{-# NOINLINE unpackDouble# #-} + +instance BitPack () where + type BitSize () = 0 + pack _ = minBound + unpack _ = () + instance (KnownNat (BitSize b), BitPack a, BitPack b) => BitPack (a,b) where type BitSize (a,b) = BitSize a + BitSize b @@ -130,5 +222,5 @@ -- 00_0001 -- >>> boolToBV False :: BitVector 6 -- 00_0000 -boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1) +boolToBV :: KnownNat n => Bool -> BitVector (n + 1) boolToBV = zeroExtend . pack diff --git a/src/CLaSH/Class/Resize.hs b/src/CLaSH/Class/Resize.hs --- a/src/CLaSH/Class/Resize.hs +++ b/src/CLaSH/Class/Resize.hs @@ -4,18 +4,18 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Class.Resize where -import GHC.TypeLits (KnownNat, Nat, type (+)) +import GHC.TypeLits (Nat, KnownNat, type (+)) -- | Coerce a value to be represented by a different number of bits class Resize (f :: Nat -> *) where @@ -31,11 +31,12 @@ 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 :: (KnownNat a, KnownNat b) => 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) + zeroExtend :: (KnownNat a, KnownNat b) => 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) + signExtend :: (KnownNat a, KnownNat b) => f a -> f (b + a) + signExtend = resize -- | Remove bits from the MSB truncateB :: KnownNat a => f (a + b) -> f a diff --git a/src/CLaSH/Examples.hs b/src/CLaSH/Examples.hs --- a/src/CLaSH/Examples.hs +++ b/src/CLaSH/Examples.hs @@ -96,7 +96,7 @@ let upCounter :: Signal Bool -> Signal (Unsigned 8) upCounter enable = s where - s = regEn 0 enable (s + 1) + s = register 0 (mux enable (s + 1) s) :} >>> :{ @@ -156,7 +156,7 @@ let oneHotCounter :: Signal Bool -> Signal (BitVector 8) oneHotCounter enable = s where - s = regEn 1 enable (rotateL s 1) + s = register 1 (mux enable (rotateL <$> s <*> 1) s) :} >>> :{ @@ -179,7 +179,7 @@ let crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) crc enable ld dIn = s where - s = regEn 0xFFFF enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) + s = register 0xFFFF (mux enable (mux ld 0xFFFF (crcT <$> s <*> dIn)) s) :} >>> :{ @@ -389,13 +389,13 @@ {- $counters = 8-bit Simple Up Counter -Using `regEn`: +Using `register`: @ upCounter :: Signal Bool -> Signal (Unsigned 8) upCounter enable = s where - s = `regEn` 0 enable (s + 1) + s = `register` 0 (`mux` enable (s + 1) s) @ = 8-bit Up Counter With Load @@ -484,7 +484,7 @@ oneHotCounter :: Signal Bool -> Signal (BitVector 8) oneHotCounter enable = s where - s = 'regEn' 1 enable ('rotateL' s 1) + s = 'register' 1 ('mux' enable ('rotateL' '<$>' s '<*>' 1) s) @ -} @@ -520,7 +520,7 @@ crc :: Signal Bool -> Signal Bool -> Signal Bit -> Signal (BitVector 16) crc enable ld dIn = s where - s = 'regEn' 0xFFFF enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) + s = 'register' 0xFFFF ('mux' enable ('mux' ld 0xFFFF (crcT '<$>' s '<*>' dIn)) s) @ -} diff --git a/src/CLaSH/NamedTypes.hs b/src/CLaSH/NamedTypes.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/NamedTypes.hs @@ -0,0 +1,65 @@ +{- | +Copyright : (C) 2017, QBayLogic +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +Add inline documentation to types: + +@ +fifo + :: SClock clk + -> SNat addrSize + -> "read request" ::: Signal' clk Bool + -> "write request" ::: Signal' clk (Maybe (BitVector dataSize)) + -> ( "q" ::: Signal' clk (BitVector dataSize) + , "full" ::: Signal' clk Bool + , "empty" ::: Signal' clk Bool + ) +@ + +which can subsequently be inspected in the interactive environment: + +>>> :t fifo systemClock +fifo systemClock + :: SNat addrSize + -> "read request" ::: Signal' SystemClock Bool + -> "write request" + ::: Signal' SystemClock (Maybe (BitVector dataSize)) + -> ("q" ::: Signal' SystemClock (BitVector dataSize), + "full" ::: Signal' SystemClock Bool, + "empty" ::: Signal' SystemClock Bool) + +-} + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Safe #-} + +{-# OPTIONS_HADDOCK show-extensions #-} + +module CLaSH.NamedTypes + ((:::)) +where + +type (name :: k) ::: a = a +-- ^ Annotate a type with a name + +{- $setup +>>> :set -XDataKinds -XTypeOperators -XNoImplicitPrelude +>>> import CLaSH.Prelude +>>> import CLaSH.Prelude.Explicit +>>> :{ +let fifo + :: SClock clk + -> SNat addrSize + -> "read request" ::: Signal' clk Bool + -> "write request" ::: Signal' clk (Maybe (BitVector dataSize)) + -> ( "q" ::: Signal' clk (BitVector dataSize) + , "full" ::: Signal' clk Bool + , "empty" ::: Signal' clk Bool + ) + fifo = CLaSH.Prelude.undefined +:} + +-} diff --git a/src/CLaSH/Prelude.hs b/src/CLaSH/Prelude.hs --- a/src/CLaSH/Prelude.hs +++ b/src/CLaSH/Prelude.hs @@ -102,13 +102,8 @@ , module CLaSH.Promoted.Nat , module CLaSH.Promoted.Nat.Literals , module CLaSH.Promoted.Nat.TH - -- ** Type-level functions - , module CLaSH.Promoted.Ord -- ** Template Haskell , Lift (..) -#if __GLASGOW_HASKELL__ < 711 - , deriveLift -#endif -- ** Type classes -- *** CLaSH , module CLaSH.Class.BitPack @@ -118,6 +113,11 @@ , module Control.Applicative , module Data.Bits , module Data.Default + -- ** Exceptions + , module CLaSH.XException + , undefined + -- ** Named types + , module CLaSH.NamedTypes -- ** Haskell Prelude -- $hiding , module Prelude @@ -128,26 +128,21 @@ import Data.Bits import Data.Default import GHC.TypeLits -#if MIN_VERSION_ghc_typelits_extra(0,2,0) -import GHC.TypeLits.Extra hiding (Max, Min) -#else import GHC.TypeLits.Extra -#endif import Language.Haskell.TH.Syntax (Lift(..)) -#if __GLASGOW_HASKELL__ < 711 -import Language.Haskell.TH.Lift (deriveLift) -#endif import Prelude hiding ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3, - zip, zip3, zipWith, zipWith3) + zip, zip3, zipWith, zipWith3, + undefined) import CLaSH.Annotations.TopEntity import CLaSH.Class.BitPack import CLaSH.Class.Num import CLaSH.Class.Resize +import CLaSH.NamedTypes import CLaSH.Prelude.BitIndex import CLaSH.Prelude.BitReduction import CLaSH.Prelude.BlockRam.File (blockRamFile, blockRamFilePow2) @@ -160,7 +155,6 @@ 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 @@ -171,6 +165,7 @@ import CLaSH.Signal import CLaSH.Signal.Delayed import CLaSH.Signal.Explicit (systemClock) +import CLaSH.XException {- $setup >>> :set -XDataKinds @@ -197,6 +192,7 @@ -- -- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int] -- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... +-- ... window :: (KnownNat n, Default a) => Signal a -- ^ Signal to create a window over -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 @@ -210,7 +206,8 @@ -- -- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] -- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... -windowD :: (KnownNat (n + 1), Default a) +-- ... +windowD :: (KnownNat n, Default a) => Signal a -- ^ Signal to create a window over -> Vec (n + 1) (Signal a) -- ^ Window of at least size 1 windowD = windowD' systemClock diff --git a/src/CLaSH/Prelude/BitIndex.hs b/src/CLaSH/Prelude/BitIndex.hs --- a/src/CLaSH/Prelude/BitIndex.hs +++ b/src/CLaSH/Prelude/BitIndex.hs @@ -41,6 +41,7 @@ -- 0 -- >>> (7 :: Unsigned 6) ! 6 -- *** Exception: (!): 6 is out of range [5..0] +-- ... (!) :: (BitPack a, KnownNat (BitSize a), Enum i) => a -> i -> Bit (!) v i = index# (pack v) (fromEnum i) @@ -56,12 +57,11 @@ -- >>> slice d6 d4 (7 :: Unsigned 6) -- -- :... --- 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 d6 d4 (7 :: Unsigned 6) --- In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6) +-- • Couldn't match type ‘7 + i0’ with ‘6’ +-- arising from a use of ‘slice’ +-- The type variable ‘i0’ is ambiguous +-- • In the expression: slice d6 d4 (7 :: Unsigned 6) +-- In an equation for ‘it’: it = slice d6 d4 (7 :: Unsigned 6) slice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> a -> BitVector (m + 1 - n) slice m n v = slice# (pack v) m n @@ -95,6 +95,7 @@ -- 01_1011 -- >>> replaceBit 6 0 (-5 :: Signed 6) -- *** Exception: replaceBit: 6 is out of range [5..0] +-- ... replaceBit :: (BitPack a, KnownNat (BitSize a), Enum i) => i -> Bit -> a -> a replaceBit i b v = unpack (replaceBit# (pack v) (fromEnum i) b) @@ -113,12 +114,11 @@ -- >>> setSlice d6 d5 0 (-5 :: Signed 6) -- -- :... --- 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 d6 d5 0 (- 5 :: Signed 6) --- In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6) +-- • Couldn't match type ‘7 + i0’ with ‘6’ +-- arising from a use of ‘setSlice’ +-- The type variable ‘i0’ is ambiguous +-- • In the expression: setSlice d6 d5 0 (- 5 :: Signed 6) +-- In an equation for ‘it’: it = setSlice d6 d5 0 (- 5 :: Signed 6) setSlice :: (BitPack a, BitSize a ~ ((m + 1) + i)) => SNat m -> SNat n -> BitVector (m + 1 - n) -> a -> a setSlice m n w v = unpack (setSlice# (pack v) m n w) 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 @@ -16,11 +16,10 @@ codes: @ -{\-\# LANGUAGE RecordWildCards \#-\} +{\-\# LANGUAGE RecordWildCards, TupleSections \#-\} module CPU where import CLaSH.Prelude -import qualified Data.List as L type InstrAddr = Unsigned 8 type MemAddr = Unsigned 5 @@ -56,13 +55,12 @@ , aluCode :: Operator , ldReg :: Reg , rdAddr :: MemAddr - , wrAddr :: MemAddr - , wrEn :: Bool + , wrAddrM :: Maybe MemAddr , jmpM :: Maybe Value } nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm - , ldReg = Zero, wrAddr = 0, rdAddr = 0, wrEn = False + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing , jmpM = Nothing } @ @@ -73,9 +71,9 @@ cpu :: Vec 7 Value -- ^ Register bank -> (Value,Instruction) -- ^ (Memory output, Current instruction) -> ( Vec 7 Value - , (MemAddr,MemAddr,Bool,Value,InstrAddr) + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) ) -cpu regbank (memOut,instr) = (regbank',(rdAddr,wrAddr,wrEn,aluOut,fromIntegral ipntr)) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) where -- Current instruction pointer ipntr = regbank '!!' PC @@ -86,7 +84,7 @@ Branch cr a -> nullCode {inputX=cr,jmpM=Just a} Jump a -> nullCode {aluCode=Incr,jmpM=Just a} Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddr=a,wrEn=True} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} Nop -> nullCode -- ALU @@ -116,18 +114,17 @@ We initially create a memory out of simple registers: @ -dataMem :: Signal MemAddr -- ^ Read address - -> Signal MemAddr -- ^ Write address - -> Signal Bool -- ^ Write enable - -> Signal Value -- ^ data in - -> Signal Value -- ^ data out -dataMem wr rd en din = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (wr,rd,en,din)) +dataMem :: Signal MemAddr -- ^ Read address + -> Signal (Maybe (MemAddr,Value)) -- ^ (write address, data in) + -> Signal Value -- ^ data out +dataMem rd wrM = 'CLaSH.Prelude.Mealy.mealy' dataMemT ('replicate' d32 0) (bundle (rd,wrM)) where - dataMemT mem (wr,rd,en,din) = (mem',dout) + dataMemT mem (rd,wrM) = (mem',dout) where dout = mem '!!' rd - mem' | en = 'replace' wr din mem - | otherwise = mem + mem' = case wrM of + Just (wr,din) -> 'replace' wr din mem + _ -> mem @ And then connect everything: @@ -136,8 +133,8 @@ system :: KnownNat n => Vec n Instruction -> Signal Value system instrs = memOut where - memOut = dataMem wrAddr rdAddr wrEn aluOut - (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'CLaSH.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr) + memOut = dataMem rdAddr dout + (rdAddr,dout,ipntr) = 'CLaSH.Prelude.Mealy.mealyB' cpu ('replicate' d7 0) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -178,8 +175,9 @@ And test our system: @ -__>>> sampleN 31 $ system prog__ +>>> sampleN 31 $ system prog [0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + @ to see that our system indeed calculates that the GCD of 6 and 4 is 2. @@ -197,8 +195,8 @@ system2 :: KnownNat n => Vec n Instruction -> Signal Value system2 instrs = memOut where - memOut = 'CLaSH.Prelude.RAM.asyncRam' d32 wrAddr rdAddr wrEn aluOut - (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr) + memOut = 'CLaSH.Prelude.RAM.asyncRam' d32 rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' cpu ('replicate' d7 0) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -208,8 +206,9 @@ output samples are also 'undefined'. @ -__>>> L.drop 5 $ sampleN 31 $ system2 prog__ -[4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] +>>> printX $ sampleN 31 $ system2 prog +[X,X,X,X,X,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + @ === Improvement 2: using @blockRam@ @@ -236,9 +235,9 @@ cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) -> (Value,Instruction) -- ^ (Memory output, Current instruction) -> ( (Vec 7 Value,Reg) - , (MemAddr,MemAddr,Bool,Value,InstrAddr) + , (MemAddr, Maybe (MemAddr,Value), InstrAddr) ) -cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,wrAddr,wrEn,aluOut,fromIntegral ipntr)) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) '<$>' wrAddrM,fromIntegral ipntr)) where -- Current instruction pointer ipntr = regbank '!!' PC @@ -249,7 +248,7 @@ Branch cr a -> nullCode {inputX=cr,jmpM=Just a} Jump a -> nullCode {aluCode=Incr,jmpM=Just a} Load a r -> nullCode {ldReg=r,rdAddr=a} - Store r a -> nullCode {inputX=r,wrAddr=a,wrEn=True} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} Nop -> nullCode -- ALU @@ -277,8 +276,8 @@ system3 :: KnownNat n => Vec n Instruction -> Signal Value system3 instrs = memOut where - memOut = 'blockRam' (replicate d32 0) wrAddr rdAddr wrEn aluOut - (rdAddr,wrAddr,wrEn,aluOut,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr) + memOut = 'blockRam' (replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = 'mealyB' cpu2 (('replicate' d7 0),Zero) (memOut,instr) instr = 'CLaSH.Prelude.ROM.asyncRom' instrs '<$>' ipntr @ @@ -327,21 +326,23 @@ also 'undefined'. @ -__>>> L.tail $ sampleN 33 $ system3 prog2__ -[0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] +>>> printX $ sampleN 33 $ system3 prog2 +[X,0,0,0,0,0,4,4,4,4,4,4,4,4,6,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,2] + @ This concludes the short introduction to using 'blockRam'. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.BlockRam @@ -359,18 +360,263 @@ ) 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, type (^)) +import Prelude hiding (length) import CLaSH.Signal (Signal, mux) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (bundle') +import CLaSH.Signal.Bundle (bundle, unbundle) import CLaSH.Sized.Unsigned (Unsigned) -import CLaSH.Sized.Vector (Vec, maxIndex, toList) +import CLaSH.Sized.Vector (Vec, length, toList) +import CLaSH.XException (XException, errorX) +{- $setup +>>> import CLaSH.Prelude as C +>>> import qualified Data.List as L +>>> :set -XDataKinds -XRecordWildCards -XTupleSections +>>> type InstrAddr = Unsigned 8 +>>> type MemAddr = Unsigned 5 +>>> type Value = Signed 8 +>>> :{ +data Reg + = Zero + | PC + | RegA + | RegB + | RegC + | RegD + | RegE + deriving (Eq,Show,Enum) +:} + +>>> :{ +data Operator = Add | Sub | Incr | Imm | CmpGt + deriving (Eq,Show) +:} + +>>> :{ +data Instruction + = Compute Operator Reg Reg Reg + | Branch Reg Value + | Jump Value + | Load MemAddr Reg + | Store Reg MemAddr + | Nop + deriving (Eq,Show) +:} + +>>> :{ +data MachCode + = MachCode + { inputX :: Reg + , inputY :: Reg + , result :: Reg + , aluCode :: Operator + , ldReg :: Reg + , rdAddr :: MemAddr + , wrAddrM :: Maybe MemAddr + , jmpM :: Maybe Value + } +:} + +>>> :{ +nullCode = MachCode { inputX = Zero, inputY = Zero, result = Zero, aluCode = Imm + , ldReg = Zero, rdAddr = 0, wrAddrM = Nothing + , jmpM = Nothing + } +:} + +>>> :{ +alu Add x y = x + y +alu Sub x y = x - y +alu Incr x _ = x + 1 +alu Imm x _ = x +alu CmpGt x y = if x > y then 1 else 0 +:} + +>>> :{ +cpu :: Vec 7 Value -- ^ Register bank + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( Vec 7 Value + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu regbank (memOut,instr) = (regbank',(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldReg memOut + $ regbank +:} + +>>> :{ +dataMem :: Signal MemAddr + -> Signal (Maybe (MemAddr,Value)) + -> Signal Value +dataMem rd wrM = mealy dataMemT (C.replicate d32 0) (bundle (rd,wrM)) + where + dataMemT mem (rd,wrM) = (mem',dout) + where + dout = mem C.!! rd + mem' = case wrM of + Just (wr,din) -> replace wr din mem + Nothing -> mem +:} + +>>> :{ +system :: KnownNat n => Vec n Instruction -> Signal Value +system instrs = memOut + where + memOut = dataMem rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +-- Compute GCD of 4 and 6 +prog = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +>>> :{ +system2 :: KnownNat n => Vec n Instruction -> Signal Value +system2 instrs = memOut + where + memOut = asyncRam d32 rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu (C.replicate d7 0) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +cpu2 :: (Vec 7 Value,Reg) -- ^ (Register bank, Load reg addr) + -> (Value,Instruction) -- ^ (Memory output, Current instruction) + -> ( (Vec 7 Value,Reg) + , (MemAddr,Maybe (MemAddr,Value),InstrAddr) + ) +cpu2 (regbank,ldRegD) (memOut,instr) = ((regbank',ldRegD'),(rdAddr,(,aluOut) <$> wrAddrM,fromIntegral ipntr)) + where + -- Current instruction pointer + ipntr = regbank C.!! PC + -- Decoder + (MachCode {..}) = case instr of + Compute op rx ry res -> nullCode {inputX=rx,inputY=ry,result=res,aluCode=op} + Branch cr a -> nullCode {inputX=cr,jmpM=Just a} + Jump a -> nullCode {aluCode=Incr,jmpM=Just a} + Load a r -> nullCode {ldReg=r,rdAddr=a} + Store r a -> nullCode {inputX=r,wrAddrM=Just a} + Nop -> nullCode + -- ALU + regX = regbank C.!! inputX + regY = regbank C.!! inputY + aluOut = alu aluCode regX regY + -- next instruction + nextPC = case jmpM of + Just a | aluOut /= 0 -> ipntr + a + _ -> ipntr + 1 + -- update registers + ldRegD' = ldReg -- Delay the ldReg by 1 cycle + regbank' = replace Zero 0 + $ replace PC nextPC + $ replace result aluOut + $ replace ldRegD memOut + $ regbank +:} + +>>> :{ +system3 :: KnownNat n => Vec n Instruction -> Signal Value +system3 instrs = memOut + where + memOut = blockRam (C.replicate d32 0) rdAddr dout + (rdAddr,dout,ipntr) = mealyB cpu2 ((C.replicate d7 0),Zero) (memOut,instr) + instr = asyncRom instrs <$> ipntr +:} + +>>> :{ +prog2 = -- 0 := 4 + Compute Incr Zero RegA RegA :> + C.replicate d3 (Compute Incr RegA Zero RegA) C.++ + Store RegA 0 :> + -- 1 := 6 + Compute Incr Zero RegA RegA :> + C.replicate d5 (Compute Incr RegA Zero RegA) C.++ + Store RegA 1 :> + -- A := 4 + Load 0 RegA :> + -- B := 6 + Load 1 RegB :> + Nop :> -- Extra NOP + -- start + Compute CmpGt RegA RegB RegC :> + Branch RegC 4 :> + Compute CmpGt RegB RegA RegC :> + Branch RegC 4 :> + Jump 5 :> + -- (a > b) + Compute Sub RegA RegB RegA :> + Jump (-6) :> + -- (b > a) + Compute Sub RegB RegA RegB :> + Jump (-8) :> + -- end + Store RegA 2 :> + Load 2 RegC :> + Nil +:} + +-} + {-# INLINE blockRam #-} -- | Create a blockRAM with space for @n@ elements. -- @@ -378,8 +624,9 @@ -- * __NB__: Initial output value is 'undefined' -- -- @ --- bram40 :: 'Signal' ('Unsigned' 6) -> Signal ('Unsigned' 6) -> 'Signal' Bool --- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -> Signal 'CLaSH.Sized.BitVector.Bit' +-- bram40 :: 'Signal' ('Unsigned' 6) +-- -> 'Signal' (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit')) +-- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -- bram40 = 'blockRam' ('CLaSH.Sized.Vector.replicate' d40 1) -- @ -- @@ -387,16 +634,15 @@ -- -- * 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) wr rd en dt@. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRam inits) rd wrM@. blockRam :: (KnownNat n, Enum addr) => Vec n a -- ^ Initial content of the BRAM, also -- determines the size, @n@, of the BRAM. -- -- __NB__: __MUST__ be a constant. - -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address @w@) + -> Signal (Maybe (addr, a)) + -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle @@ -409,8 +655,9 @@ -- * __NB__: Initial output value is 'undefined' -- -- @ --- bram32 :: 'Signal' ('Unsigned' 5) -> Signal ('Unsigned' 5) -> 'Signal' Bool --- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit' +-- bram32 :: 'Signal' ('Unsigned' 5) +-- -> 'Signal' (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit')) +-- -> 'Signal' 'CLaSH.Sized.BitVector.Bit' -- bram32 = 'blockRamPow2' ('CLaSH.Sized.Vector.replicate' d32 1) -- @ -- @@ -418,20 +665,19 @@ -- -- * 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 (blockRamPow2 inits) wr rd en dt@. -blockRamPow2 :: (KnownNat (2^n), KnownNat n) +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamPow2 inits) rd wrM@. +blockRamPow2 :: 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 (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle -blockRamPow2 = blockRam +blockRamPow2 = blockRamPow2' systemClock {-# INLINE blockRam' #-} -- | Create a blockRAM with space for @n@ elements @@ -445,8 +691,9 @@ -- clkA100 :: SClock ClkA -- clkA100 = 'CLaSH.Signal.Explicit.sclock' -- --- bram40 :: 'Signal'' ClkA ('Unsigned' 6) -> 'Signal'' ClkA ('Unsigned' 6) --- -> 'Signal'' ClkA Bool -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -> ClkA 'Signal'' 'CLaSH.Sized.BitVector.Bit' +-- bram40 :: 'Signal'' ClkA ('Unsigned' 6) +-- -> 'Signal'' ClkA (Maybe ('Unsigned' 6, 'CLaSH.Sized.BitVector.Bit')) +-- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -- bram40 = 'blockRam'' clkA100 ('CLaSH.Sized.Vector.replicate' d40 1) -- @ -- @@ -454,22 +701,25 @@ -- -- * 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) wr rd en dt@. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRam' clk inits) rd wrM@. blockRam' :: (KnownNat n, Enum addr) => 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. - -> Signal' clk addr -- ^ Write address @w@ -> Signal' clk addr -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk a -- ^ Value to write (at address @w@) + -> Signal' clk (Maybe (addr, a)) + -- ^ (write address @w@, value to write) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle -blockRam' clk content wr rd en din = blockRam# clk content (fromEnum <$> wr) - (fromEnum <$> rd) en din +blockRam' clk content rd wrM = + blockRam# clk content + (fromEnum <$> rd) + (isJust <$> wrM) + ((fromEnum . fst . fromJust) <$> wrM) + ((snd . fromJust) <$> wrM) {-# INLINE blockRamPow2' #-} -- | Create a blockRAM with space for 2^@n@ elements @@ -483,8 +733,9 @@ -- clkA100 :: SClock ClkA -- clkA100 = 'CLaSH.Signal.Explicit.sclock' -- --- bram32 :: 'Signal'' ClkA ('Unsigned' 5) -> Signal' ClkA ('Unsigned' 5) --- -> 'Signal'' ClkA Bool -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -> Signal' ClkA 'CLaSH.Sized.BitVector.Bit' +-- bram32 :: 'Signal'' ClkA ('Unsigned' 5) +-- -> 'Signal'' ClkA (Maybe ('Unsigned' 5, 'CLaSH.Sized.BitVector.Bit')) +-- -> 'Signal'' ClkA 'CLaSH.Sized.BitVector.Bit' -- bram32 = 'blockRamPow2'' clkA100 ('CLaSH.Sized.Vector.replicate' d32 1) -- @ -- @@ -492,24 +743,22 @@ -- -- * 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 (blockRamPow2' clk inits) wr rd en dt@. -blockRamPow2' :: (KnownNat n, KnownNat (2^n)) +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamPow2' clk inits) rd wrM@. +blockRamPow2' :: KnownNat 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. - -> Signal' clk (Unsigned n) -- ^ Write address @w@ -> Signal' clk (Unsigned n) -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk a -- ^ Value to write (at address @w@) + -> Signal' clk (Maybe (Unsigned n, a)) + -- ^ (Write address @w@, value to write) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle blockRamPow2' = blockRam' -{-# NOINLINE blockRam# #-} -- | blockRAM primitive blockRam# :: KnownNat n => SClock clk -- ^ 'Clock' to synchronize to @@ -517,40 +766,66 @@ -- determines the size, @n@, of the BRAM. -- -- __NB__: __MUST__ be a constant. - -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk Int -- ^ Read address @r@ -> Signal' clk Bool -- ^ Write enable + -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk a -- ^ Value to write (at address @w@) -> Signal' clk a -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle -blockRam# clk content wr rd en din = register' clk undefined dout +blockRam# clk content rd en wr din = + register' clk (errorX "blockRam#: intial value undefined") dout where - szI = maxIndex content + szI = length content dout = runST $ do - arr <- newListArray (0,szI) (toList content) - traverse (ramT arr) (bundle' clk (wr,rd,en,din)) + arr <- newListArray (0,szI-1) (toList content) + traverse (ramT arr) (bundle (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e - ramT ram (w,r,e,d) = do - d' <- readArray ram r + 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' +{-# NOINLINE blockRam# #-} -- | Create read-after-write blockRAM from a read-before-write one (synchronised to specified clock) -- -readNew' :: Eq addr => SClock clk -> (Signal' clk addr -> Signal' clk addr -> Signal' clk Bool -> Signal' clk a -> Signal' clk a) -> Signal' clk addr -> Signal' clk addr -> Signal' clk Bool -> Signal' clk a -> Signal' clk a -readNew' clk ram wrAddr rdAddr wrEn wrData = mux wasSame wasWritten $ ram wrAddr rdAddr wrEn wrData - where sameAddr = (==) <$> wrAddr <*> rdAddr - wasSame = register' clk False ((&&) <$> wrEn <*> sameAddr) - wasWritten = register' clk undefined wrData +readNew' :: Eq addr + => SClock clk + -> (Signal' clk addr -> Signal' clk (Maybe (addr, a)) -> Signal' clk a) + -- ^ The @ram@ component + -> Signal' clk addr -- ^ Read address @r@ + -> Signal' clk (Maybe (addr, a)) -- ^ (Write address @w@, value to write) + -> Signal' clk a + -- ^ Value of the @ram@ at address @r@ from the previous clock + -- cycle +readNew' clk ram rdAddr wrM = mux wasSame wasWritten $ ram rdAddr wrM + where readNewT rd (Just (wr, wrdata)) = (wr == rd, wrdata) + readNewT _ Nothing = (False , undefined) + (wasSame,wasWritten) = unbundle (register' clk (False,undefined) + (readNewT <$> rdAddr <*> wrM)) + -- | Create read-after-write blockRAM from a read-before-write one (synchronised to system clock) -- -- >>> import CLaSH.Prelude -- >>> :t readNew (blockRam (0 :> 1 :> Nil)) -- readNew (blockRam (0 :> 1 :> Nil)) --- :: (Enum addr, Eq addr, Num a) => --- Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a -readNew :: Eq addr => (Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a) -> Signal addr -> Signal addr -> Signal Bool -> Signal a -> Signal a +-- :: ... => +-- Signal addr -> Signal (Maybe (addr, a)) -> Signal a +readNew :: Eq addr + => (Signal addr -> Signal (Maybe (addr, a)) -> Signal a) + -- ^ The @ram@ component + -> Signal addr -- ^ Read address @r@ + -> Signal (Maybe (addr, a)) -- ^ (Write address @w@, value to write) + -> Signal a + -- ^ Value of the @ram@ at address @r@ from the previous clock + -- cycle readNew = readNew' systemClock 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 @@ -33,7 +33,7 @@ @ topEntity :: Signal (Unsigned 3) -> Signal (Unsigned 9) -topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" 0 rd (signal False) 0 +topEntity rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) @ In the example above, we basically treat the BlockRAM as an synchronous ROM. @@ -50,7 +50,7 @@ @ topEntity2 :: Signal (Unsigned 3) -> Signal (Unsigned 6,Signed 3) -topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" 0 rd (signal False) 0 +topEntity2 rd = 'CLaSH.Class.BitPack.unpack' '<$>' 'blockRamFile' d7 \"memory.bin\" rd (signal Nothing) @ And then we would see: @@ -64,13 +64,14 @@ -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.BlockRam.File @@ -86,22 +87,24 @@ ) 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 (listToMaybe) -import GHC.TypeLits (KnownNat, type (^)) +import Data.Maybe (fromJust, isJust, listToMaybe) +import GHC.TypeLits (KnownNat) import Numeric (readInt) -import CLaSH.Promoted.Nat (SNat,snat,snatToInteger) +import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) 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.Bundle (bundle) import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.XException (XException, errorX) {-# INLINE blockRamFile #-} -- | Create a blockRAM with space for @n@ elements @@ -125,7 +128,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 (blockRamFile size file) wr rd en dt@. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFile size file) rd wrM@. -- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your @@ -134,10 +137,9 @@ => SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial content -- of the blockRAM - -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal (BitVector m) -- ^ Value to write (at address @w@) + -> Signal (Maybe (addr, BitVector m)) + -- ^ (write address @w@, value to write) -> Signal (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle @@ -165,22 +167,21 @@ -- -- * 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 (blockRamFilePow2 file) wr rd en dt@. +-- * Use the adapter 'readNew' for obtaining write-before-read semantics like this: @readNew (blockRamFilePow2 file) rd wrM@. -- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. -blockRamFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n)) +blockRamFilePow2 :: (KnownNat m, KnownNat n) => FilePath -- ^ File describing the initial -- content of the blockRAM - -> Signal (Unsigned n) -- ^ Write address @w@ - -> Signal (Unsigned n) -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal (BitVector m) -- ^ Value to write (at address @w@) + -> Signal (Unsigned n) -- ^ Read address @r@ + -> Signal (Maybe (Unsigned n, BitVector m)) + -- ^ (write address @w@, value to write)@) -> Signal (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle -blockRamFilePow2 = blockRamFile' systemClock (snat :: SNat (2^n)) +blockRamFilePow2 = blockRamFilePow2' systemClock {-# INLINE blockRamFilePow2' #-} -- | Create a blockRAM with space for 2^@n@ elements @@ -204,23 +205,22 @@ -- -- * 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 (blockRamFilePow2' clk file) wr rd en dt@. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFilePow2' clk file) rd wrM@. -- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. -blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n, KnownNat (2^n)) +blockRamFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) => SClock clk -- ^ 'Clock' to synchronize to -> FilePath -- ^ File describing the initial -- content of the blockRAM - -> Signal' clk (Unsigned n) -- ^ Write address @w@ -> Signal' clk (Unsigned n) -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@) + -> Signal' clk (Maybe (Unsigned n, BitVector m)) + -- ^ (write address @w@, value to write) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle -blockRamFilePow2' clk = blockRamFile' clk (snat :: SNat (2^n)) +blockRamFilePow2' clk = blockRamFile' clk (pow2SNat (SNat @ n)) {-# INLINE blockRamFile' #-} -- | Create a blockRAM with space for @n@ elements @@ -244,7 +244,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 (blockRamFile' clk size file) wr rd en dt@. +-- * Use the adapter 'readNew'' for obtaining write-before-read semantics like this: @readNew' clk (blockRamFile' clk size file) rd wrM@. -- * See "CLaSH.Prelude.BlockRam.File#usingramfiles" for more information on how -- to instantiate a Block RAM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your @@ -254,17 +254,18 @@ -> SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial -- content of the blockRAM - -> Signal' clk addr -- ^ Write address @w@ -> Signal' clk addr -- ^ Read address @r@ - -> Signal' clk Bool -- ^ Write enable - -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@) + -> Signal' clk (Maybe (addr, BitVector m)) + -- ^ (write address @w@, value to write) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle -blockRamFile' clk sz file wr rd en din = blockRamFile# clk sz file - (fromEnum <$> wr) - (fromEnum <$> rd) - en din +blockRamFile' clk sz file rd wrM = + blockRamFile# clk sz file + (fromEnum <$> rd) + (isJust <$> wrM) + ((fromEnum . fst . fromJust) <$> wrM) + ((snd . fromJust) <$> wrM) {-# NOINLINE blockRamFile# #-} -- | blockRamFile primitive @@ -273,24 +274,30 @@ -> SNat n -- ^ Size of the blockRAM -> FilePath -- ^ File describing the initial -- content of the blockRAM - -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk Int -- ^ Read address @r@ -> Signal' clk Bool -- ^ Write enable + -> Signal' clk Int -- ^ Write address @w@ -> Signal' clk (BitVector m) -- ^ Value to write (at address @w@) -> Signal' clk (BitVector m) -- ^ Value of the @blockRAM@ at address @r@ from the previous -- clock cycle -blockRamFile# clk sz file wr rd en din = register' clk undefined dout +blockRamFile# clk sz file rd en wr din = register' clk (errorX "blockRamFile#: intial value undefined") dout where - szI = fromInteger $ snatToInteger sz + szI = snatToNum sz dout = runST $ do mem <- unsafeIOToST (initMem file) arr <- newListArray (0,szI-1) mem - traverse (ramT arr) (bundle' clk (wr,rd,en,din)) + traverse (ramT arr) (bundle (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e - ramT ram (w,r,e,d) = do - d' <- readArray ram r + 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' diff --git a/src/CLaSH/Prelude/DataFlow.hs b/src/CLaSH/Prelude/DataFlow.hs --- a/src/CLaSH/Prelude/DataFlow.hs +++ b/src/CLaSH/Prelude/DataFlow.hs @@ -7,17 +7,16 @@ -} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.DataFlow @@ -54,8 +53,9 @@ import CLaSH.Prelude.BitIndex (msb) import CLaSH.Prelude.Mealy (mealyB') import CLaSH.Promoted.Nat (SNat) -import CLaSH.Signal ((.&&.), not1, regEn, unbundle) +import CLaSH.Signal ((.&&.), unbundle) import CLaSH.Signal.Bundle (Bundle (..)) +import CLaSH.Signal.Internal (regEn#) import CLaSH.Signal.Explicit (Clock (..), Signal', SystemClock, sclock) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Vector @@ -147,49 +147,47 @@ -- | Create a 'DataFlow' circuit from a Mealy machine description as those of -- "CLaSH.Prelude.Mealy" -mealyDF :: (s -> i -> (s,o)) +mealyDF :: (KnownSymbol nm, KnownNat rate) + => (s -> i -> (s,o)) -> s - -> DataFlow Bool Bool i o + -> DataFlow' ('Clk nm rate) 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' + s = regEn# sclock iS en s' in (o,iV,oR)) -- | Create a 'DataFlow' circuit from a Moore machine description as those of -- "CLaSH.Prelude.Moore" -mooreDF :: (s -> i -> s) +mooreDF :: (KnownSymbol nm, KnownNat rate) + => (s -> i -> s) -> (s -> o) -> s - -> DataFlow Bool Bool i o + -> DataFlow' ('Clk nm rate) Bool Bool i o mooreDF ft fo iS = DF (\i iV oR -> let en = iV .&&. oR s' = ft <$> s <*> i - s = regEn iS en s' + s = regEn# sclock iS en s' o = fo <$> s in (o,iV,oR)) -fifoDF_mealy :: forall addrSize a . - (KnownNat addrSize - ,KnownNat (addrSize + 1) - ,KnownNat (2 ^ addrSize)) +fifoDF_mealy :: forall addrSize a . KnownNat addrSize => (Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) -> (a, Bool, Bool) -> ((Vec (2^addrSize) a, BitVector (addrSize + 1), BitVector (addrSize + 1)) ,(a, Bool, Bool)) fifoDF_mealy (mem,rptr,wptr) (wdata,winc,rinc) = - ((mem',rptr',wptr'), (rdata,empty,full)) - where - raddr = truncateB rptr :: BitVector addrSize - waddr = truncateB wptr :: BitVector addrSize + let raddr = truncateB rptr :: BitVector addrSize + waddr = truncateB wptr :: BitVector addrSize - mem' | winc && not full = replace waddr wdata mem - | otherwise = mem + mem' | winc && not full = replace waddr wdata mem + | otherwise = mem - rdata = mem !! raddr + rdata = mem !! raddr - rptr' = rptr + boolToBV (rinc && not empty) - wptr' = wptr + boolToBV (winc && not full) - empty = rptr == wptr - full = msb rptr /= msb wptr && raddr == waddr + rptr' = rptr + boolToBV (rinc && not empty) + wptr' = wptr + boolToBV (winc && not full) + empty = rptr == wptr + full = msb rptr /= msb wptr && raddr == waddr + in ((mem',rptr',wptr'), (rdata,empty,full)) -- | Create a FIFO buffer adhering to the 'DataFlow' protocol. Can be filled -- with initial content. @@ -200,11 +198,7 @@ -- fifo4 = 'fifoDF' d4 (2 :> 3 :> Nil) -- @ fifoDF :: forall addrSize m n a nm rate . - (KnownNat addrSize, - KnownNat n, KnownNat m, - KnownNat (2 ^ addrSize), - KnownNat (addrSize + 1), - (m + n) ~ (2 ^ addrSize), + (KnownNat addrSize, KnownNat n, KnownNat m, (m + n) ~ (2 ^ addrSize), KnownSymbol nm, KnownNat rate) => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two. -> Vec m a -- ^ Initial content. Can be smaller than the size of the @@ -217,7 +211,7 @@ initMem = iS ++ repeat undefined :: Vec (m + n) a initS = (initMem,initRdPtr,initWrPtr) (o,empty,full) = mealyB' clk fifoDF_mealy initS (i,iV,oR) - in (o,not1 empty, not1 full) + in (o,not <$> empty, not <$> full) -- | Identity circuit -- @@ -239,24 +233,22 @@ -- 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 +firstDF :: DataFlow' clk aEn bEn a b + -> DataFlow' clk (aEn,cEn) (bEn,cEn) (a,c) (b,c) +firstDF (DF f) = DF (\ac acV bcR -> let (a,c) = unbundle ac + (aV,cV) = unbundle acV + (bR,cR) = unbundle bcR (b,bV,aR) = f a aV bR - bc = bundle' clk (b,c) - bcV = bundle' clk (bV,cV) - acR = bundle' clk (aR,cR) + bc = bundle (b,c) + bcV = bundle (bV,cV) + acR = bundle (aR,cR) in (bc,bcV,acR) ) -- | Swap the two communication channels. -- -- <> -swapDF :: DataFlow' ('Clk nm rate) (aEn,bEn) (bEn,aEn) (a,b) (b,a) +swapDF :: DataFlow' clk (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) @@ -265,37 +257,34 @@ -- 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 :: DataFlow' clk aEn bEn a b + -> DataFlow' clk (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) +parDF :: DataFlow' clk aEn bEn a b + -> DataFlow' clk cEn dEn c d + -> DataFlow' clk (aEn,cEn) (bEn,dEn) (a,c) (b,d) f `parDF` g = firstDF f `seqDF` secondDF g -- | Compose /n/ 'DataFlow' circuits in parallel. -parNDF :: (KnownSymbol nm, KnownNat rate, KnownNat n) - => Vec n (DataFlow' ('Clk nm rate) aEn bEn a b) - -> DataFlow' ('Clk nm rate) +parNDF :: KnownNat n + => Vec n (DataFlow' clk aEn bEn a b) + -> DataFlow' clk (Vec n aEn) (Vec n bEn) (Vec n a) (Vec n b) parNDF fs = DF (\as aVs bRs -> - let clk = sclock - as' = unbundle' clk as - aVs' = unbundle' clk aVs - bRs' = unbundle' clk bRs + let as' = unbundle as + aVs' = unbundle aVs + bRs' = unbundle bRs (bs,bVs,aRs) = unzip3 (zipWith (\k (a,b,r) -> df k a b r) fs (zip3 (lazyV as') (lazyV aVs') bRs')) - in (bundle' clk bs,bundle' clk bVs, bundle' clk aRs) + in (bundle bs,bundle bVs, bundle aRs) ) -- | Feed back the second halve of the communication channel. The feedback loop @@ -340,9 +329,8 @@ -- @ -- -- <> -loopDF :: (KnownNat m, KnownNat n, KnownNat rate, KnownNat addrSize - ,KnownNat (2 ^ addrSize), KnownNat (addrSize + 1), KnownSymbol nm - ,(m+n) ~ (2^addrSize)) +loopDF :: (KnownNat m, KnownNat n, KnownNat addrSize, KnownNat rate + ,KnownSymbol nm,(m+n) ~ (2^addrSize)) => SNat (m + n) -- ^ Depth of the FIFO buffer. Must be a power of two -> Vec m d -- ^ Initial content of the FIFO buffer. Can be smaller than -- the size of the FIFO. Empty spaces are initialised with @@ -350,32 +338,29 @@ -> DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) -> DataFlow' ('Clk nm rate) Bool Bool a b loopDF sz is (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 + DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR + (b,d) = unbundle bd + (bV,dV) = unbundle bdV + (aR,dR) = unbundle adR (d_buf,dV_buf,dR_buf) = df (fifoDF sz is) d dV dR - ad = bundle' clk (a,d_buf) - adV = bundle' clk (aV,dV_buf) - bdR = bundle' clk (bR,dR_buf) + ad = bundle (a,d_buf) + adV = bundle (aV,dV_buf) + bdR = bundle (bR,dR_buf) in (b,bV,aR) ) -- | Feed back the second halve of the communication channel. Unlike 'loopDF', -- the feedback loop is /not/ buffered. -loopDF_nobuf :: (KnownSymbol nm, KnownNat rate) - => DataFlow' ('Clk nm rate) (Bool,Bool) (Bool,Bool) (a,d) (b,d) - -> DataFlow' ('Clk nm rate) Bool Bool a b -loopDF_nobuf (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) +loopDF_nobuf :: DataFlow' clk (Bool,Bool) (Bool,Bool) (a,d) (b,d) + -> DataFlow' clk Bool Bool a b +loopDF_nobuf (DF f) = DF (\a aV bR -> let (bd,bdV,adR) = f ad adV bdR + (b,d) = unbundle bd + (bV,dV) = unbundle bdV + (aR,dR) = unbundle adR + ad = bundle (a,d) + adV = bundle (aV,dV) + bdR = bundle (bR,dR) in (b,bV,aR) ) @@ -445,8 +430,7 @@ -- @ -- -- Does the right thing. - lockStep :: (KnownNat rate,KnownSymbol nm) - => DataFlow' ('Clk nm rate) a Bool b b + lockStep :: DataFlow' clk a Bool b b -- | Extend the synchronisation granularity from a single 'Bool'ean value. -- @@ -512,8 +496,7 @@ -- @ -- -- Does the right thing. - stepLock :: (KnownNat rate,KnownSymbol nm) - => DataFlow' ('Clk nm rate) Bool a b b + stepLock :: DataFlow' clk Bool a b b instance LockStep Bool c where lockStep = idDF @@ -521,37 +504,36 @@ 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 + (DF (\xy xyV rdy -> let (xV,yV) = unbundle xyV val = xV .&&. yV xR = yV .&&. rdy yR = xV .&&. rdy - xyR = bundle' clk (xR,yR) + xyR = bundle (xR,yR) in (xy,val,xyR))) - stepLock = (DF (\xy val xyR -> let clk = sclock - (xR,yR) = unbundle' clk xyR + stepLock = (DF (\xy val xyR -> let (xR,yR) = unbundle xyR rdy = xR .&&. yR xV = val .&&. yR yV = val .&&. xR - xyV = bundle' clk (xV,yV) + xyV = bundle (xV,yV) in (xy,xyV,rdy))) `seqDF` (stepLock `parDF` stepLock) -instance (LockStep en a, KnownNat m, m ~ (n + 1), KnownNat (n+1)) => - LockStep (Vec m en) (Vec m a) where +instance (LockStep en a, KnownNat n) => LockStep (Vec n en) (Vec n a) where lockStep = parNDF (repeat lockStep) `seqDF` DF (\xs vals rdy -> - let val = and <$> vals - rdys = allReady <$> rdy <*> (repeat <$> vals) + let val = (and . (True :>)) <$> vals + rdys = allReady <$> rdy <*> (repeat . (:< True) <$> vals) in (xs,val,rdys) ) stepLock = DF (\xs val rdys -> - let rdy = and <$> rdys - vals = allReady <$> val <*> (repeat <$> rdys) + let rdy = (and . (True :>)) <$> rdys + vals = allReady <$> val <*> (repeat . (:< True) <$> rdys) in (xs,vals,rdy) ) `seqDF` parNDF (repeat stepLock) -allReady :: KnownNat (n+1) => Bool -> Vec (n+1) (Vec (n+1) Bool) - -> Vec (n+1) Bool +allReady :: KnownNat n + => Bool + -> Vec n (Vec (n+1) Bool) + -> Vec n Bool allReady b vs = map (and . (b :>) . tail) (smap (flip rotateLeftS) vs) 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 @@ -12,13 +12,12 @@ using explicitly clocked signals. -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.Explicit @@ -74,6 +73,7 @@ {- $setup >>> :set -XDataKinds +>>> import CLaSH.Prelude >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA >>> let window4 = window' clkA :: Signal' ClkA Int -> Vec 4 (Signal' ClkA Int) @@ -93,8 +93,9 @@ -- window4 = 'window'' clkA -- @ -- --- >>> simulateB' clkA clkA window4 [1::Int,2,3,4,5] :: [Vec 4 Int] +-- >>> simulateB window4 [1::Int,2,3,4,5] :: [Vec 4 Int] -- [<1,0,0,0>,<2,1,0,0>,<3,2,1,0>,<4,3,2,1>,<5,4,3,2>... +-- ... window' :: (KnownNat n, Default a) => SClock clk -- ^ Clock to which the incoming -- signal is synchronized @@ -102,7 +103,7 @@ -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1 window' clk x = res where - res = x `Cons` prev + res = x :> prev prev = case natVal (asNatProxy prev) of 0 -> repeat def _ -> let next = x +>> prev @@ -121,14 +122,15 @@ -- windowD3 = 'windowD'' clkA -- @ -- --- >>> simulateB' clkA clkA windowD3 [1::Int,2,3,4] :: [Vec 3 Int] +-- >>> simulateB windowD3 [1::Int,2,3,4] :: [Vec 3 Int] -- [<0,0,0>,<1,0,0>,<2,1,0>,<3,2,1>,<4,3,2>... -windowD' :: (KnownNat (n + 1), Default a) +-- ... +windowD' :: (KnownNat n, Default a) => SClock clk -- ^ Clock to which the incoming signal -- is synchronized -> Signal' clk a -- ^ Signal to create a window over -> Vec (n + 1) (Signal' clk a) -- ^ Window of at least size 1 -windowD' clk x = prev - where - prev = registerB' clk (repeat def) next - next = x +>> prev +windowD' clk x = + let prev = registerB' clk (repeat def) next + next = x +>> prev + in prev diff --git a/src/CLaSH/Prelude/Explicit/Safe.hs b/src/CLaSH/Prelude/Explicit/Safe.hs --- a/src/CLaSH/Prelude/Explicit/Safe.hs +++ b/src/CLaSH/Prelude/Explicit/Safe.hs @@ -60,10 +60,12 @@ import CLaSH.Prelude.ROM (rom', romPow2') import CLaSH.Prelude.Synchronizer (dualFlipFlopSynchronizer, asyncFIFOSynchronizer) +import CLaSH.Signal.Bundle (Bundle(..), Unbundled') import CLaSH.Signal.Explicit {- $setup >>> :set -XDataKinds +>>> import CLaSH.Prelude >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA >>> let rP = registerB' clkA (8::Int,8::Int) @@ -83,10 +85,11 @@ -- rP = 'registerB'' clkA (8,8) -- @ -- --- >>> simulateB' clkA clkA rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] +-- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] -- [(8,8),(1,1),(2,2),(3,3)... +-- ... registerB' :: Bundle a => SClock clk -> a -> Unbundled' clk a -> Unbundled' clk a -registerB' clk i = unbundle' clk Prelude.. register' clk i Prelude.. bundle' clk +registerB' clk i = unbundle Prelude.. register' clk i Prelude.. bundle {-# INLINABLE isRising' #-} -- | Give a pulse when the 'Signal'' goes from 'minBound' to 'maxBound' diff --git a/src/CLaSH/Prelude/Mealy.hs b/src/CLaSH/Prelude/Mealy.hs --- a/src/CLaSH/Prelude/Mealy.hs +++ b/src/CLaSH/Prelude/Mealy.hs @@ -67,6 +67,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14... +-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart: @@ -158,6 +159,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14... +-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart: @@ -178,7 +180,7 @@ -> (Signal' clk i -> Signal' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the mealy machine -mealy' clk f iS = \i -> let (s',o) = unbundle' clk $ f <$> s <*> i +mealy' clk f iS = \i -> let (s',o) = unbundle $ f <$> s <*> i s = register' clk iS s' in o @@ -217,4 +219,4 @@ -> (Unbundled' clk i -> Unbundled' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the mealy machine -mealyB' clk f iS i = unbundle' clk (mealy' clk f iS (bundle' clk i)) +mealyB' clk f iS i = unbundle (mealy' clk f iS (bundle i)) diff --git a/src/CLaSH/Prelude/Moore.hs b/src/CLaSH/Prelude/Moore.hs --- a/src/CLaSH/Prelude/Moore.hs +++ b/src/CLaSH/Prelude/Moore.hs @@ -16,9 +16,13 @@ ( -- * Moore machine synchronised to the system clock moore , mooreB + , medvedev + , medvedevB -- * Moore machine synchronised to an arbitrary clock , moore' , mooreB' + , medvedev' + , medvedevB' ) where @@ -58,6 +62,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14... +-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart: @@ -81,6 +86,12 @@ -- of the moore machine moore = moore' systemClock +{-# INLINE medvedev #-} +-- | Create a synchronous function from a combinational function describing +-- a moore machine without any output logic +medvedev :: (s -> i -> s) -> s -> Signal i -> Signal s +medvedev tr st = moore tr id st + {-# INLINE mooreB #-} -- | A version of 'moore' that does automatic 'Bundle'ing -- @@ -120,6 +131,11 @@ -- of the moore machine mooreB = mooreB' systemClock +{-# INLINE medvedevB #-} +-- | A version of 'medvedev' that does automatic 'Bundle'ing +medvedevB :: (Bundle i, Bundle s) => (s -> i -> s) -> s -> Unbundled i -> Unbundled s +medvedevB tr st = mooreB tr id st + {-# INLINABLE moore' #-} -- | Create a synchronous function from a combinational function describing -- a moore machine @@ -141,6 +157,7 @@ -- -- >>> simulate topEntity [(1,1),(2,2),(3,3),(4,4)] -- [0,1,5,14... +-- ... -- -- Synchronous sequential functions can be composed just like their -- combinational counterpart: @@ -167,6 +184,12 @@ s = register' clk iS s' in fo <$> s +{-# INLINE medvedev' #-} +-- | Create a synchronous function from a combinational function describing +-- a moore machine without any output logic +medvedev' :: SClock clk -> (s -> i -> s) -> s -> (Signal' clk i -> Signal' clk s) +medvedev' clk tr st = moore' clk tr id st + {-# INLINE mooreB' #-} -- | A version of 'moore'' that does automatic 'Bundle'ing -- @@ -205,4 +228,9 @@ -> (Unbundled' clk i -> Unbundled' clk o) -- ^ Synchronous sequential function with input and output matching that -- of the moore machine -mooreB' clk ft fo iS i = unbundle' clk (moore' clk ft fo iS (bundle' clk i)) +mooreB' clk ft fo iS i = unbundle (moore' clk ft fo iS (bundle i)) + +{-# INLINE medvedevB' #-} +-- | A version of 'medvedev'' that does automatic 'Bundle'ing +medvedevB' :: (Bundle i, Bundle s) => SClock clk -> (s -> i -> s) -> s -> Unbundled' clk i -> Unbundled' clk s +medvedevB' clk tr st = mooreB' clk tr id st 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 @@ -11,16 +11,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c -- as to why we need this. -#if __GLASGOW_HASKELL__ > 711 {-# OPTIONS_GHC -fno-cpr-anal #-} -#endif {-# OPTIONS_HADDOCK show-extensions #-} @@ -36,17 +35,21 @@ ) where +import Control.Exception (catch, evaluate, throw) import Control.Monad (when) import Control.Monad.ST.Lazy (ST,runST) -import Data.Array.MArray.Safe (newArray_,readArray,writeArray) +import Control.Monad.ST.Lazy.Unsafe (unsafeIOToST) +import Data.Array.MArray.Safe (newListArray,readArray,writeArray) import Data.Array.ST.Safe (STArray) -import GHC.TypeLits (KnownNat, type (^)) +import Data.Maybe (fromJust, isJust) +import GHC.TypeLits (KnownNat) -import CLaSH.Promoted.Nat (SNat,snat,snatToInteger) +import CLaSH.Promoted.Nat (SNat (..), snatToNum, pow2SNat) import CLaSH.Signal (Signal) -import CLaSH.Signal.Bundle (bundle') +import CLaSH.Signal.Bundle (bundle) import CLaSH.Signal.Explicit (Signal', SClock, systemClock, unsafeSynchronizer) import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.XException (XException, errorX) {-# INLINE asyncRam #-} -- | Create a RAM with space for @n@ elements. @@ -59,10 +62,9 @@ -- RAM. asyncRam :: Enum addr => SNat n -- ^ Size @n@ of the RAM - -> Signal addr -- ^ Write address @w@ -> Signal addr -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address @w@) + -> Signal (Maybe (addr, a)) + -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @RAM@ at address @r@ asyncRam = asyncRam' systemClock systemClock @@ -75,13 +77,12 @@ -- -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM. -asyncRamPow2 :: forall n a . (KnownNat (2^n), KnownNat n) - => Signal (Unsigned n) -- ^ Write address @w@ - -> Signal (Unsigned n) -- ^ Read address @r@ - -> Signal Bool -- ^ Write enable - -> Signal a -- ^ Value to write (at address @w@) +asyncRamPow2 :: KnownNat n + => Signal (Unsigned n) -- ^ Read address @r@ + -> Signal (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) -> Signal a -- ^ Value of the @RAM@ at address @r@ -asyncRamPow2 = asyncRam' systemClock systemClock (snat :: SNat (2^n)) +asyncRamPow2 = asyncRamPow2' systemClock systemClock {-# INLINE asyncRamPow2' #-} -- | Create a RAM with space for 2^@n@ elements @@ -93,19 +94,18 @@ -- * See "CLaSH.Prelude.BlockRam#usingrams" for more information on how to use a -- RAM. asyncRamPow2' :: forall wclk rclk n a . - (KnownNat n, KnownNat (2^n)) + KnownNat n => SClock wclk -- ^ 'Clock' to which to synchronise -- the write port of the RAM -> SClock rclk -- ^ 'Clock' to which the read -- address signal, @r@, is -- synchronised - -> Signal' wclk (Unsigned n) -- ^ Write address @w@ -> Signal' rclk (Unsigned n) -- ^ Read address @r@ - -> Signal' wclk Bool -- ^ Write enable - -> Signal' wclk a -- ^ Value to write (at address @w@) - -> Signal' rclk a + -> Signal' wclk (Maybe (Unsigned n, a)) + -- ^ (write address @w@, value to write) + -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ -asyncRamPow2' wclk rclk = asyncRam' wclk rclk (snat :: SNat (2^n)) +asyncRamPow2' wclk rclk = asyncRam' wclk rclk (pow2SNat (SNat @ n)) {-# INLINE asyncRam' #-} -- | Create a RAM with space for @n@ elements @@ -122,14 +122,18 @@ -> SClock rclk -- ^ 'Clock' to which the read address signal, -- @r@, is synchronised -> SNat n -- ^ Size @n@ of the RAM - -> Signal' wclk addr -- ^ Write address @w@ -> Signal' rclk addr -- ^ Read address @r@ - -> Signal' wclk Bool -- ^ Write enable - -> Signal' wclk a -- ^ Value to write (at address @w@) + -> Signal' wclk (Maybe (addr, a)) + -- ^ (write address @w@, value to write) -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ -asyncRam' wclk rclk sz wr rd en din = asyncRam# wclk rclk sz (fromEnum <$> wr) - (fromEnum <$> rd) en din +asyncRam' wclk rclk sz rd wrM = + asyncRam# wclk rclk sz + (fromEnum <$> rd) + (isJust <$> wrM) + ((fromEnum . fst . fromJust) <$> wrM) + ((snd . fromJust) <$> wrM) + {-# NOINLINE asyncRam# #-} -- | RAM primitive asyncRam# :: SClock wclk -- ^ 'Clock' to which to synchronise the write @@ -137,21 +141,27 @@ -> SClock rclk -- ^ 'Clock' to which the read address signal, -- @r@, is synchronised -> SNat n -- ^ Size @n@ of the RAM - -> Signal' wclk Int -- ^ Write address @w@ -> Signal' rclk Int -- ^ Read address @r@ -> Signal' wclk Bool -- ^ Write enable + -> Signal' wclk Int -- ^ Write address @w@ -> Signal' wclk a -- ^ Value to write (at address @w@) -> Signal' rclk a -- ^ Value of the @RAM@ at address @r@ -asyncRam# wclk rclk sz wr rd en din = unsafeSynchronizer wclk rclk dout +asyncRam# wclk rclk sz rd en wr din = unsafeSynchronizer wclk rclk dout where - szI = fromInteger $ snatToInteger sz + szI = snatToNum sz rd' = unsafeSynchronizer rclk wclk rd dout = runST $ do - arr <- newArray_ (0,szI-1) - traverse (ramT arr) (bundle' wclk (wr,rd',en,din)) + arr <- newListArray (0,szI-1) (replicate szI (errorX "asyncRam#: initial value undefined")) + traverse (ramT arr) (bundle (rd',en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e - ramT ram (w,r,e,d) = do - d' <- readArray ram r + 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' diff --git a/src/CLaSH/Prelude/ROM.hs b/src/CLaSH/Prelude/ROM.hs --- a/src/CLaSH/Prelude/ROM.hs +++ b/src/CLaSH/Prelude/ROM.hs @@ -6,13 +6,13 @@ ROMs -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.ROM @@ -33,12 +33,14 @@ import Data.Array ((!),listArray) import GHC.TypeLits (KnownNat, type (^)) +import Prelude hiding (length) import CLaSH.Signal (Signal) import CLaSH.Signal.Explicit (Signal', SClock, systemClock) import CLaSH.Sized.Unsigned (Unsigned) import CLaSH.Signal.Explicit (register') -import CLaSH.Sized.Vector (Vec, maxIndex, toList) +import CLaSH.Sized.Vector (Vec, length, toList) +import CLaSH.XException (errorX) {-# INLINE asyncRom #-} -- | An asynchronous/combinational ROM with space for @n@ elements @@ -62,7 +64,7 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs -asyncRomPow2 :: (KnownNat (2^n), KnownNat n) +asyncRomPow2 :: KnownNat n => Vec (2^n) a -- ^ ROM content -- -- __NB:__ must be a constant @@ -80,8 +82,8 @@ -> a -- ^ The value of the ROM at address @rd@ asyncRom# content rd = arr ! rd where - szI = maxIndex content - arr = listArray (0,szI) (toList content) + szI = length content + arr = listArray (0,szI-1) (toList content) {-# INLINE rom #-} -- | A ROM with a synchronous read port, with space for @n@ elements @@ -111,13 +113,13 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs -romPow2 :: (KnownNat (2^n), KnownNat n) +romPow2 :: KnownNat n => Vec (2^n) a -- ^ ROM content -- -- __NB:__ must be a constant -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal a -- ^ The value of the ROM at address @rd@ -romPow2 = rom' systemClock +romPow2 = romPow2' systemClock {-# INLINE romPow2' #-} -- | A ROM with a synchronous read port, with space for 2^@n@ elements @@ -129,7 +131,7 @@ -- -- * See "CLaSH.Sized.Fixed#creatingdatafiles" and "CLaSH.Prelude.BlockRam#usingrams" -- for ideas on how to use ROMs and RAMs -romPow2' :: (KnownNat (2^n), KnownNat n) +romPow2' :: KnownNat n => SClock clk -- ^ 'Clock' to synchronize to -> Vec (2^n) a -- ^ ROM content -- @@ -168,7 +170,7 @@ -> Signal' clk Int -- ^ Read address @rd@ -> Signal' clk a -- ^ The value of the ROM at address @rd@ from the previous clock cycle -rom# clk content rd = register' clk undefined ((arr !) <$> rd) +rom# clk content rd = register' clk (errorX "rom#: initial value undefined") ((arr !) <$> rd) where - szI = maxIndex content - arr = listArray (0,szI) (toList content) + szI = length content + arr = listArray (0,szI-1) (toList content) diff --git a/src/CLaSH/Prelude/ROM/File.hs b/src/CLaSH/Prelude/ROM/File.hs --- a/src/CLaSH/Prelude/ROM/File.hs +++ b/src/CLaSH/Prelude/ROM/File.hs @@ -65,6 +65,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Unsafe #-} @@ -88,15 +89,16 @@ where import Data.Array (listArray,(!)) -import GHC.TypeLits (KnownNat, type (^)) +import GHC.TypeLits (KnownNat) import System.IO.Unsafe (unsafePerformIO) import CLaSH.Prelude.BlockRam.File (initMem) -import CLaSH.Promoted.Nat (SNat,snat,snatToInteger) +import CLaSH.Promoted.Nat (SNat (..), pow2SNat, snatToNum) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Signal (Signal) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.XException (errorX) {-# INLINE asyncRomFile #-} -- | An asynchronous/combinational ROM with space for @n@ elements @@ -164,7 +166,7 @@ -- > where -- > mem = unsafePerformIO (initMem file) -- > content = listArray (0,szI-1) mem --- > szI = fromInteger (snatToInteger sz) +-- > szI = snatToNum sz -- -- We write: -- @@ -172,7 +174,7 @@ -- > where -- > mem = unsafePerformIO (initMem file) -- > content = listArray (0,szI-1) mem --- > szI = fromInteger (snatToInteger sz) +-- > szI = snatToNum sz -- -- Where instead of returning the BitVector defined by @(content ! rd)@, we -- return the function (thunk) @(content !)@. @@ -213,11 +215,11 @@ -- myRomData :: Unsigned 9 -> BitVector 16 -- myRomData = asyncRomFilePow2 "memory.bin" -- @ -asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n)) +asyncRomFilePow2 :: forall n m . (KnownNat m, KnownNat n) => FilePath -- ^ File describing the content of the ROM -> Unsigned n -- ^ Read address @rd@ -> BitVector m -- ^ The value of the ROM at address @rd@ -asyncRomFilePow2 = asyncRomFile (snat :: SNat (2^n)) +asyncRomFilePow2 = asyncRomFile (pow2SNat (SNat @ n)) {-# NOINLINE asyncRomFile# #-} -- | asyncROMFile primitive @@ -230,7 +232,7 @@ where -- Note [Eta-reduction and unsafePerformIO initMem] mem = unsafePerformIO (initMem file) content = listArray (0,szI-1) mem - szI = fromInteger (snatToInteger sz) + szI = snatToNum sz {-# INLINE romFile #-} -- | A ROM with a synchronous read port, with space for @n@ elements @@ -256,10 +258,10 @@ -- to instantiate a ROM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. -romFile :: (KnownNat m, KnownNat k) +romFile :: (KnownNat m, KnownNat n) => SNat n -- ^ Size of the ROM -> FilePath -- ^ File describing the content of the ROM - -> Signal (Unsigned k) -- ^ Read address @rd@ + -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle romFile = romFile' systemClock @@ -288,12 +290,12 @@ -- to instantiate a ROM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. -romFilePow2 :: forall n m . (KnownNat m, KnownNat n, KnownNat (2^n)) +romFilePow2 :: forall n m . (KnownNat m, KnownNat n) => FilePath -- ^ File describing the content of the ROM -> Signal (Unsigned n) -- ^ Read address @rd@ -> Signal (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFilePow2 = romFile' systemClock (snat :: SNat (2^n)) +romFilePow2 = romFilePow2' systemClock {-# INLINE romFilePow2' #-} -- | A ROM with a synchronous read port, with space for 2^@n@ elements @@ -319,7 +321,7 @@ -- to instantiate a ROM with the contents of a data file. -- * See "CLaSH.Sized.Fixed#creatingdatafiles" for ideas on how to create your -- own data files. -romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n, KnownNat (2^n)) +romFilePow2' :: forall clk n m . (KnownNat m, KnownNat n) => SClock clk -- ^ 'Clock' to synchronize to -> FilePath -- ^ File describing the content of -- the ROM @@ -327,7 +329,7 @@ -> Signal' clk (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock -- cycle -romFilePow2' clk = romFile' clk (snat :: SNat (2^n)) +romFilePow2' clk = romFile' clk (pow2SNat (SNat @ n)) {-# INLINE romFile' #-} -- | A ROM with a synchronous read port, with space for @n@ elements @@ -373,8 +375,8 @@ -> Signal' clk Int -- ^ Read address @rd@ -> Signal' clk (BitVector m) -- ^ The value of the ROM at address @rd@ from the previous clock cycle -romFile# clk sz file rd = register' clk undefined ((content !) <$> rd) +romFile# clk sz file rd = register' clk (errorX "romFile#: initial value undefined") ((content !) <$> rd) where mem = unsafePerformIO (initMem file) content = listArray (0,szI-1) mem - szI = fromInteger (snatToInteger sz) + szI = snatToNum sz diff --git a/src/CLaSH/Prelude/Safe.hs b/src/CLaSH/Prelude/Safe.hs --- a/src/CLaSH/Prelude/Safe.hs +++ b/src/CLaSH/Prelude/Safe.hs @@ -27,7 +27,6 @@ Some circuit examples can be found in "CLaSH.Examples". -} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} @@ -90,8 +89,6 @@ , module CLaSH.Promoted.Nat , module CLaSH.Promoted.Nat.Literals , module CLaSH.Promoted.Nat.TH - -- ** Type-level functions - , module CLaSH.Promoted.Ord -- ** Type classes -- *** CLaSH , module CLaSH.Class.BitPack @@ -100,6 +97,11 @@ -- *** Other , module Control.Applicative , module Data.Bits + -- ** Exceptions + , module CLaSH.XException + , undefined + -- ** Named types + , module CLaSH.NamedTypes -- ** Haskell Prelude -- $hiding , module Prelude @@ -108,23 +110,22 @@ import Control.Applicative import Data.Bits +import GHC.Stack import GHC.TypeLits -#if MIN_VERSION_ghc_typelits_extra(0,2,0) -import GHC.TypeLits.Extra hiding (Max, Min) -#else import GHC.TypeLits.Extra -#endif import Prelude hiding ((++), (!!), concat, drop, foldl, foldl1, foldr, foldr1, head, init, iterate, last, length, map, repeat, replicate, reverse, scanl, scanr, splitAt, tail, take, unzip, unzip3, - zip, zip3, zipWith, zipWith3) + zip, zip3, zipWith, zipWith3, + undefined) import CLaSH.Annotations.TopEntity import CLaSH.Class.BitPack import CLaSH.Class.Num import CLaSH.Class.Resize +import CLaSH.NamedTypes import CLaSH.Prelude.BitIndex import CLaSH.Prelude.BitReduction import CLaSH.Prelude.BlockRam (blockRam, blockRamPow2, readNew, readNew') @@ -137,7 +138,6 @@ 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 @@ -148,6 +148,7 @@ import CLaSH.Signal import CLaSH.Signal.Delayed import CLaSH.Signal.Explicit (systemClock) +import CLaSH.XException {- $setup >>> let rP = registerB (8,8) @@ -171,8 +172,10 @@ -- -- >>> simulateB rP [(1,1),(2,2),(3,3)] :: [(Int,Int)] -- [(8,8),(1,1),(2,2),(3,3)... +-- ... registerB :: Bundle a => a -> Unbundled a -> Unbundled a registerB = registerB' systemClock +infixr 3 `registerB` {-# INLINE isRising #-} -- | Give a pulse when the 'Signal' goes from 'minBound' to 'maxBound' @@ -189,3 +192,6 @@ -> Signal a -> Signal Bool isFalling = isFalling' systemClock + +undefined :: HasCallStack => a +undefined = errorX "undefined" diff --git a/src/CLaSH/Prelude/Synchronizer.hs b/src/CLaSH/Prelude/Synchronizer.hs --- a/src/CLaSH/Prelude/Synchronizer.hs +++ b/src/CLaSH/Prelude/Synchronizer.hs @@ -6,15 +6,21 @@ Synchronizer circuits for safe clock domain crossings -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} + {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Prelude.Synchronizer @@ -25,16 +31,25 @@ ) where +import Control.Applicative (liftA2) import Data.Bits (complement, shiftR, xor) -import GHC.TypeLits (type (+)) +import Data.Constraint ((:-)(..), Dict (..)) +#if MIN_VERSION_constraints(0,9,0) +import Data.Constraint.Nat (leTrans) +#else +import Unsafe.Coerce +#endif +import Data.Maybe (isJust) +import GHC.TypeLits (type (+), type (-), type (<=)) import CLaSH.Class.BitPack (boolToBV) +import CLaSH.Class.Resize (truncateB) import CLaSH.Prelude.BitIndex (slice) import CLaSH.Prelude.Mealy (mealyB') import CLaSH.Prelude.RAM (asyncRam') -import CLaSH.Promoted.Nat (SNat, powSNat, subSNat) -import CLaSH.Promoted.Nat.Literals (d0, d1, d2) -import CLaSH.Signal ((.&&.), not1) +import CLaSH.Promoted.Nat (SNat (..), pow2SNat) +import CLaSH.Promoted.Nat.Literals (d0) +import CLaSH.Signal (mux) import CLaSH.Signal.Explicit (Signal', SClock, register', unsafeSynchronizer) import CLaSH.Sized.BitVector (BitVector, (++#)) @@ -77,78 +92,85 @@ -- * Asynchronous FIFO synchronizer -fifoMem :: _ - => SClock wclk - -> SClock rclk - -> SNat addrSize - -> Signal' wclk (BitVector addrSize) - -> Signal' rclk (BitVector addrSize) - -> Signal' wclk Bool - -> Signal' wclk Bool - -> Signal' wclk a - -> Signal' rclk a -fifoMem wclk rclk addrSize waddr raddr winc wfull wdata = +fifoMem :: + SClock wclk + -> SClock rclk + -> SNat addrSize + -> Signal' wclk Bool + -> Signal' rclk (BitVector addrSize) + -> Signal' wclk (Maybe (BitVector addrSize, a)) + -> Signal' rclk a +fifoMem wclk rclk addrSize@SNat full raddr writeM = asyncRam' wclk rclk - (d2 `powSNat` addrSize) - waddr raddr - (winc .&&. not1 wfull) - wdata + (pow2SNat addrSize) + raddr + (mux full (pure Nothing) writeM) -ptrCompareT :: _ - => SNat addrSize +ptrCompareT :: SNat addrSize -> (BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool) -> (BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) -> (BitVector (addrSize + 1), Bool) -> ((BitVector (addrSize + 1), BitVector (addrSize + 1), Bool) ,(Bool, BitVector addrSize, BitVector (addrSize + 1))) -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') - ,(flag,addr,ptr)) +ptrCompareT SNat flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') + ,(flag,addr,ptr)) where -- GRAYSTYLE2 pointer bin' = bin + boolToBV (inc && not flag) ptr' = (bin' `shiftR` 1) `xor` bin' - addr = slice (addrSize `subSNat` d1) d0 bin + addr = truncateB bin flag' = flagGen ptr' s_ptr - -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} -isFull :: _ +isFull :: forall addrSize . + (2 <= addrSize) => SNat addrSize -> BitVector (addrSize + 1) -> BitVector (addrSize + 1) -> Bool -isFull addrSize ptr s_ptr = - ptr == (complement (slice addrSize (addrSize `subSNat` d1) s_ptr) ++# - slice (addrSize `subSNat` d2) d0 s_ptr) +isFull addrSize@SNat ptr s_ptr = case leTrans @1 @2 @addrSize of + Sub Dict -> + let a1 = SNat @(addrSize - 1) + a2 = SNat @(addrSize - 2) + in ptr == (complement (slice addrSize a1 s_ptr) ++# slice a2 d0 s_ptr) -- | Synchroniser implemented as a FIFO around an asynchronous RAM. Based on the -- design described in "CLaSH.Tutorial#multiclock", which is itself based on the -- design described in . -- -- __NB__: This synchroniser can be used for __word__-synchronization. -asyncFIFOSynchronizer :: _ - => SNat addrSize -- ^ Size of the internally used - -- addresses, the FIFO contains - -- @2^addrSize@ elements. - -> SClock wclk -- ^ 'Clock' to which the write port - -- is synchronised - -> SClock rclk -- ^ 'Clock' to which the read port - -- is synchronised - -> Signal' wclk a -- ^ Element to insert - -> Signal' wclk Bool -- ^ Write request - -> Signal' rclk Bool -- ^ Read request - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) - -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag) -asyncFIFOSynchronizer addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull) +asyncFIFOSynchronizer + :: (2 <= addrSize) + => SNat addrSize -- ^ Size of the internally used addresses, the + -- FIFO contains @2^addrSize@ elements. + -> SClock wclk -- ^ 'Clock' to which the write port is synchronised + -> SClock rclk -- ^ 'Clock' to which the read port is synchronised + -> Signal' rclk Bool -- ^ Read request + -> Signal' wclk (Maybe a) -- ^ Element to insert + -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) + -- ^ (Oldest element in the FIFO, @empty@ flag, @full@ flag) +asyncFIFOSynchronizer addrSize@SNat wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = dualFlipFlopSynchronizer rclk wclk 0 rptr s_wptr = dualFlipFlopSynchronizer wclk rclk 0 wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata + rdata = fifoMem wclk rclk addrSize wfull raddr + (liftA2 (,) <$> (pure <$> waddr) <*> wdataM) (rempty,raddr,rptr) = mealyB' rclk (ptrCompareT addrSize (==)) (0,0,True) (s_wptr,rinc) (wfull,waddr,wptr) = mealyB' wclk (ptrCompareT addrSize (isFull addrSize)) - (0,0,False) (s_rptr,winc) + (0,0,False) (s_rptr,isJust <$> wdataM) + +#if !MIN_VERSION_constraints(0,9,0) +axiom :: forall a b . Dict (a ~ b) +axiom = unsafeCoerce (Dict :: Dict (a ~ a)) + +axiomLe :: forall a b. Dict (a <= b) +axiomLe = axiom + +leTrans :: forall a b c. (b <= c, a <= b) :- (a <= c) +leTrans = Sub (axiomLe @a @c) +#endif diff --git a/src/CLaSH/Prelude/Testbench.hs b/src/CLaSH/Prelude/Testbench.hs --- a/src/CLaSH/Prelude/Testbench.hs +++ b/src/CLaSH/Prelude/Testbench.hs @@ -24,25 +24,25 @@ import Debug.Trace (trace) import GHC.TypeLits (KnownNat) -import Prelude hiding ((!!)) +import Prelude hiding ((!!), length) import CLaSH.Signal (Signal, fromList) import CLaSH.Signal.Explicit (Signal', SClock, register', systemClock) -import CLaSH.Signal.Bundle (unbundle') +import CLaSH.Signal.Bundle (unbundle) import CLaSH.Sized.Index (Index) -import CLaSH.Sized.Vector (Vec, (!!), maxIndex) +import CLaSH.Sized.Vector (Vec, (!!), length) {- $setup >>> :set -XTemplateHaskell >>> :set -XDataKinds >>> import CLaSH.Prelude ->>> let testInput = stimuliGenerator $(v [(1::Int),3..21]) ->>> let expectedOutput = outputVerifier $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) +>>> let testInput = stimuliGenerator $(listToVecTH [(1::Int),3..21]) +>>> let expectedOutput = outputVerifier $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) >>> import CLaSH.Prelude.Explicit >>> type ClkA = Clk "A" 100 >>> let clkA = sclock :: SClock ClkA ->>> let testInput' = stimuliGenerator' clkA $(v [(1::Int),3..21]) ->>> let expectedOutput' = outputVerifier' clkA $(v ([70,99,2,3,4,5,7,8,9,10]::[Int])) +>>> let testInput' = stimuliGenerator' clkA $(listToVecTH [(1::Int),3..21]) +>>> let expectedOutput' = outputVerifier' clkA $(listToVecTH ([70,99,2,3,4,5,7,8,9,10]::[Int])) -} {-# INLINE assert #-} @@ -70,7 +70,7 @@ -- -- @ -- testInput :: 'Signal' Int --- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.v' [(1::Int),3..21]) +-- testInput = 'stimuliGenerator' $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) -- @ -- -- >>> sampleN 13 testInput @@ -89,30 +89,30 @@ -- -- @ -- expectedOutput :: 'Signal' Int -> 'Signal' Bool --- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- expectedOutput = 'outputVerifier' $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ -- -- >>> import qualified Data.List as List -- >>> sampleN 12 (expectedOutput (fromList ([0..10] List.++ [10,10,10]))) --- [ +-- -- cycle(system1000): 0, outputVerifier -- expected value: 70, not equal to actual value: 0 --- False, +-- [False -- cycle(system1000): 1, outputVerifier -- expected value: 99, not equal to actual value: 1 --- False,False,False,False,False, +-- ,False,False,False,False,False -- cycle(system1000): 6, outputVerifier -- expected value: 7, not equal to actual value: 6 --- False, +-- ,False -- cycle(system1000): 7, outputVerifier -- expected value: 8, not equal to actual value: 7 --- False, +-- ,False -- cycle(system1000): 8, outputVerifier -- expected value: 9, not equal to actual value: 8 --- False, +-- ,False -- cycle(system1000): 9, outputVerifier -- expected value: 10, not equal to actual value: 9 --- False,True,True] +-- ,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 @@ -162,7 +162,7 @@ -- clkA = 'CLaSH.Signal.Explicit.sclock' -- -- testInput' :: 'Signal'' clkA Int --- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.v' [(1::Int),3..21]) +-- testInput' = 'stimuliGenerator'' clkA $('CLaSH.Sized.Vector.listToVecTH' [(1::Int),3..21]) -- @ -- -- >>> sampleN 13 testInput' @@ -173,13 +173,13 @@ -> Vec l a -- ^ Samples to generate -> Signal' clk a -- ^ Signal of given samples stimuliGenerator' clk samples = - let (r,o) = unbundle' clk (genT <$> register' clk 0 r) + let (r,o) = unbundle (genT <$> register' clk 0 r) in o where genT :: Index l -> (Index l,a) genT s = (s',samples !! s) where - maxI = toEnum (maxIndex samples) + maxI = toEnum (length samples - 1) s' = if s < maxI then s + 1 @@ -199,30 +199,30 @@ -- clkA = 'CLaSH.Signal.Explicit.sclock' -- -- expectedOutput' :: 'Signal'' ClkA Int -> 'Signal'' ClkA Bool --- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.v' ([70,99,2,3,4,5,7,8,9,10]::[Int])) +-- expectedOutput' = 'outputVerifier'' clkA $('CLaSH.Sized.Vector.listToVecTH' ([70,99,2,3,4,5,7,8,9,10]::[Int])) -- @ -- -- >>> import qualified Data.List as List -- >>> sampleN 12 (expectedOutput' (fromList ([0..10] List.++ [10,10,10]))) --- [ +-- -- cycle(A100): 0, outputVerifier -- expected value: 70, not equal to actual value: 0 --- False, +-- [False -- cycle(A100): 1, outputVerifier -- expected value: 99, not equal to actual value: 1 --- False,False,False,False,False, +-- ,False,False,False,False,False -- cycle(A100): 6, outputVerifier -- expected value: 7, not equal to actual value: 6 --- False, +-- ,False -- cycle(A100): 7, outputVerifier -- expected value: 8, not equal to actual value: 7 --- False, +-- ,False -- cycle(A100): 8, outputVerifier -- expected value: 9, not equal to actual value: 8 --- False, +-- ,False -- cycle(A100): 9, outputVerifier -- expected value: 10, not equal to actual value: 9 --- False,True,True] +-- ,False,True,True] outputVerifier' :: forall l clk a . (KnownNat l, Eq a, Show a) => SClock clk -- ^ Clock to which the input signal is -- synchronized to @@ -230,14 +230,14 @@ -> Signal' clk a -- ^ Signal to verify -> Signal' clk Bool -- ^ Indicator that all samples are verified outputVerifier' clk samples i = - let (s,o) = unbundle' clk (genT <$> register' clk 0 s) - (e,f) = unbundle' clk o + let (s,o) = unbundle (genT <$> register' clk 0 s) + (e,f) = unbundle o in assert' clk "outputVerifier" i e (register' clk False f) where genT :: Index l -> (Index l,(a,Bool)) genT s = (s',(samples !! s,finished)) where - maxI = toEnum (maxIndex samples) + maxI = toEnum (length samples - 1) s' = if s < maxI then s + 1 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,55 +4,118 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Promoted.Nat - ( SNat (..), snat, withSNat, snatToInteger, addSNat, subSNat, mulSNat, powSNat - , UNat (..), toUNat, addUNat, multUNat, powUNat + ( -- * Singleton natural numbers + -- ** Data type + SNat (..) + -- ** Construction + , snatProxy + , withSNat + , snat + -- ** Conversion + , snatToInteger, snatToNum + -- ** Arithmetic + , addSNat, mulSNat, powSNat + -- *** Partial + , subSNat, divSNat, modSNat, flogBaseSNat, clogBaseSNat, logBaseSNat + -- *** Specialised + , pow2SNat + -- * Unary/Peano-encoded natural numbers + -- ** Data type + , UNat (..) + -- ** Construction + , toUNat + -- ** Conversion + , fromUNat + -- ** Arithmetic + , addUNat, mulUNat, powUNat + -- *** Partial + , predUNat, subUNat + -- * Base-2 encoded natural numbers + -- ** Data type + , BNat (..) + -- ** Construction + , toBNat + -- ** Conversion + , fromBNat + -- ** Pretty printing base-2 encoded natural numbers + , showBNat + -- ** Arithmetic + , succBNat, addBNat, mulBNat, powBNat + -- *** Partial + , predBNat, div2BNat, div2Sub1BNat, log2BNat + -- ** Normalisation + , stripZeros ) where -import Data.Proxy (Proxy (..)) -import Data.Reflection (reifyNat) -import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), type (^), - natVal) -import Unsafe.Coerce (unsafeCoerce) +import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), + type (^), type (<=), natVal) +import GHC.TypeLits.Extra (CLog, FLog, Div, Log, Mod) +import Language.Haskell.TH (appT, conT, litT, numTyLit, sigE) +import Language.Haskell.TH.Syntax (Lift (..)) +import Unsafe.Coerce (unsafeCoerce) +import CLaSH.XException (ShowX (..), showsPrecXWith) +{- $setup +>>> :set -XBinaryLiterals +>>> import CLaSH.Promoted.Nat.Literals (d789) +-} + -- | 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 -data SNat (n :: Nat) = KnownNat n => SNat (Proxy n) +data SNat (n :: Nat) where + SNat :: KnownNat n => SNat n -instance Show (SNat n) where - show (SNat p) = 'd' : show (natVal p) +instance Lift (SNat n) where + lift s = sigE [| SNat |] + (appT (conT ''SNat) (litT $ numTyLit (snatToInteger s))) -{-# INLINE snat #-} -- | Create a singleton literal for a type-level natural number snat :: KnownNat n => SNat n -snat = SNat Proxy +snat = SNat +{-# DEPRECATED snat "Use 'SNat' instead of 'snat'" #-} +-- | Create an @`SNat` n@ from a proxy for /n/ +snatProxy :: KnownNat n => proxy n -> SNat n +snatProxy _ = SNat + +instance Show (SNat n) where + show p@SNat = 'd' : show (natVal p) + +instance ShowX (SNat n) where + showsPrecX = showsPrecXWith showsPrec + {-# 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) +withSNat f = f SNat {-# INLINE snatToInteger #-} -- | Reify the type-level 'Nat' @n@ to it's term-level 'Integer' representation. snatToInteger :: SNat n -> Integer -snatToInteger (SNat p) = natVal p +snatToInteger p@SNat = natVal p +-- | Reify the type-level 'Nat' @n@ to it's term-level 'Num'ber. +snatToNum :: Num a => SNat n -> a +snatToNum p@SNat = fromInteger (natVal p) +{-# INLINE snatToNum #-} + -- | Unary representation of a type-level natural -- -- __NB__: Not synthesisable @@ -60,55 +123,300 @@ UZero :: UNat 0 USucc :: UNat n -> UNat (n + 1) +instance KnownNat n => Show (UNat n) where + show x = 'u':show (natVal x) + +instance KnownNat n => ShowX (UNat n) where + showsPrecX = showsPrecXWith showsPrec + -- | Convert a singleton natural number to its unary representation -- -- __NB__: Not synthesisable toUNat :: SNat n -> UNat n -toUNat (SNat p) = fromI (natVal p) +toUNat p@SNat = fromI (natVal p) where fromI :: Integer -> UNat m fromI 0 = unsafeCoerce UZero fromI n = unsafeCoerce (USucc (fromI (n - 1))) --- | Add two unary singleton natural numbers +-- | Convert a unary-encoded natural number to its singleton representation -- -- __NB__: Not synthesisable +fromUNat :: UNat n -> SNat n +fromUNat UZero = SNat :: SNat 0 +fromUNat (USucc x) = addSNat (fromUNat x) (SNat :: SNat 1) + +-- | Add two unary-encoded 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 = USucc (addUNat x y) --- | Multiply two unary singleton natural numbers +-- | Multiply two unary-encoded natural numbers -- -- __NB__: Not synthesisable -multUNat :: UNat n -> UNat m -> UNat (n * m) -multUNat UZero _ = UZero -multUNat _ UZero = UZero -multUNat (USucc x) y = addUNat y (multUNat x y) +mulUNat :: UNat n -> UNat m -> UNat (n * m) +mulUNat UZero _ = UZero +mulUNat _ UZero = UZero +mulUNat (USucc x) y = addUNat y (mulUNat x y) --- | Power of two unary singleton natural numbers +-- | Power of two unary-encoded natural numbers -- -- __NB__: Not synthesisable powUNat :: UNat n -> UNat m -> UNat (n ^ m) powUNat _ UZero = USucc UZero -powUNat x (USucc y) = multUNat x (powUNat x y) +powUNat x (USucc y) = mulUNat x (powUNat x y) +-- | Predecessor of a unary-encoded natural number +-- +-- __NB__: Not synthesisable +predUNat :: UNat (n+1) -> UNat n +predUNat (USucc x) = x + +-- | Subtract two unary-encoded natural numbers +-- +-- __NB__: Not synthesisable +subUNat :: UNat (m+n) -> UNat n -> UNat m +subUNat x UZero = x +subUNat (USucc x) (USucc y) = subUNat x y +subUNat UZero _ = error "impossible: 0 + (n + 1) ~ 0" + -- | Add two singleton natural numbers addSNat :: SNat a -> SNat b -> SNat (a+b) -addSNat x y = reifyNat (snatToInteger x + snatToInteger y) (unsafeCoerce . SNat) -{-# NOINLINE addSNat #-} +addSNat SNat SNat = SNat +{-# INLINE addSNat #-} -- | Subtract two singleton natural numbers -subSNat :: SNat a -> SNat b -> SNat (a-b) -subSNat x y = reifyNat (snatToInteger x - snatToInteger y) (unsafeCoerce . SNat) -{-# NOINLINE subSNat #-} +subSNat :: SNat (a+b) -> SNat b -> SNat a +subSNat SNat SNat = SNat +{-# INLINE subSNat #-} -- | Multiply two singleton natural numbers mulSNat :: SNat a -> SNat b -> SNat (a*b) -mulSNat x y = reifyNat (snatToInteger x * snatToInteger y) (unsafeCoerce . SNat) -{-# NOINLINE mulSNat #-} +mulSNat SNat SNat = SNat +{-# INLINE mulSNat #-} -- | Power of two singleton natural numbers powSNat :: SNat a -> SNat b -> SNat (a^b) -powSNat x y = reifyNat (snatToInteger x ^ snatToInteger y) (unsafeCoerce . SNat) +powSNat SNat SNat = SNat {-# NOINLINE powSNat #-} + +-- | Division of two singleton natural numbers +divSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Div a b) +divSNat SNat SNat = SNat +{-# INLINE divSNat #-} + +-- | Modulo of two singleton natural numbers +modSNat :: (1 <= b) => SNat a -> SNat b -> SNat (Mod a b) +modSNat SNat SNat = SNat +{-# INLINE modSNat #-} + +-- | Floor of the logarithm of a natural number +flogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ^ Base + -> SNat x + -> SNat (FLog base x) +flogBaseSNat SNat SNat = SNat +{-# NOINLINE flogBaseSNat #-} + +-- | Ceiling of the logarithm of a natural number +clogBaseSNat :: (2 <= base, 1 <= x) + => SNat base -- ^ Base + -> SNat x + -> SNat (CLog base x) +clogBaseSNat SNat SNat = SNat +{-# NOINLINE clogBaseSNat #-} + +-- | Exact integer logarithm of a natural number +-- +-- __NB__: Only works when the argument is a power of the base +logBaseSNat :: (FLog base x ~ CLog base x) + => SNat base -- ^ Base + -> SNat x + -> SNat (Log base x) +logBaseSNat SNat SNat = SNat +{-# NOINLINE logBaseSNat #-} + +-- | Power of two of a singleton natural number +pow2SNat :: SNat a -> SNat (2^a) +pow2SNat SNat = SNat +{-# INLINE pow2SNat #-} + +-- | Base-2 encoded natural number +-- +-- * __NB__: The LSB is the left/outer-most constructor: +-- * __NB__: Not synthesisable +-- +-- >>> B0 (B1 (B1 BT)) +-- b6 +-- +-- == Constructors +-- +-- * Starting/Terminating element: +-- +-- @ +-- __BT__ :: 'BNat' 0 +-- @ +-- +-- * Append a zero (/0/): +-- +-- @ +-- __B0__ :: 'BNat' n -> 'BNat' (2 '*' n) +-- @ +-- +-- * Append a one (/1/): +-- +-- @ +-- __B1__ :: 'BNat' n -> 'BNat' ((2 '*' n) '+' 1) +-- @ +data BNat :: Nat -> * where + BT :: BNat 0 + B0 :: BNat n -> BNat (2*n) + B1 :: BNat n -> BNat ((2*n) + 1) + +instance KnownNat n => Show (BNat n) where + show x = 'b':show (natVal x) + +instance KnownNat n => ShowX (BNat n) where + showsPrecX = showsPrecXWith showsPrec + +-- | Show a base-2 encoded natural as a binary literal +-- +-- __NB__: The LSB is shown as the right-most bit +-- +-- >>> d789 +-- d789 +-- >>> toBNat d789 +-- b789 +-- >>> showBNat (toBNat d789) +-- "0b1100010101" +-- >>> 0b1100010101 :: Integer +-- 789 +showBNat :: BNat n -> String +showBNat = go [] + where + go :: String -> BNat m -> String + go xs BT = "0b" ++ xs + go xs (B0 x) = go ('0':xs) x + go xs (B1 x) = go ('1':xs) x + +-- | Convert a singleton natural number to its base-2 representation +-- +-- __NB__: Not synthesisable +toBNat :: SNat n -> BNat n +toBNat s@SNat = toBNat' (natVal s) + where + toBNat' :: Integer -> BNat m + toBNat' 0 = unsafeCoerce BT + toBNat' n = case n `divMod` 2 of + (n',1) -> unsafeCoerce (B1 (toBNat' n')) + (n',_) -> unsafeCoerce (B0 (toBNat' n')) + +-- | Convert a base-2 encoded natural number to its singleton representation +-- +-- __NB__: Not synthesisable +fromBNat :: BNat n -> SNat n +fromBNat BT = SNat :: SNat 0 +fromBNat (B0 x) = mulSNat (SNat :: SNat 2) (fromBNat x) +fromBNat (B1 x) = addSNat (mulSNat (SNat :: SNat 2) (fromBNat x)) + (SNat :: SNat 1) + +-- | Add two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +addBNat :: BNat n -> BNat m -> BNat (n+m) +addBNat (B0 a) (B0 b) = B0 (addBNat a b) +addBNat (B0 a) (B1 b) = B1 (addBNat a b) +addBNat (B1 a) (B0 b) = B1 (addBNat a b) +addBNat (B1 a) (B1 b) = B0 (succBNat (addBNat a b)) +addBNat BT b = b +addBNat a BT = a + +-- | Multiply two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +mulBNat :: BNat n -> BNat m -> BNat (n*m) +mulBNat BT _ = BT +mulBNat _ BT = BT +mulBNat (B0 a) b = B0 (mulBNat a b) +mulBNat (B1 a) b = addBNat (B0 (mulBNat a b)) b + +-- | Power of two base-2 encoded natural numbers +-- +-- __NB__: Not synthesisable +powBNat :: BNat n -> BNat m -> BNat (n^m) +powBNat _ BT = B1 BT +powBNat a (B0 b) = let z = powBNat a b + in mulBNat z z +powBNat a (B1 b) = let z = powBNat a b + in mulBNat a (mulBNat z z) + +-- | Successor of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +succBNat :: BNat n -> BNat (n+1) +succBNat BT = B1 BT +succBNat (B0 a) = B1 a +succBNat (B1 a) = B0 (succBNat a) + +-- | Predecessor of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +predBNat :: BNat (n+1) -> (BNat n) +predBNat (B1 a) = case stripZeros a of + BT -> BT + a' -> B0 a' +predBNat (B0 x) = B1 (go x) + where + go :: BNat m -> BNat (m-1) + go (B1 a) = case stripZeros a of + BT -> BT + a' -> B0 a' + go (B0 a) = B1 (go a) + go BT = error "impossible: 0 ~ 0 - 1" + +-- | Divide a base-2 encoded natural number by 2 +-- +-- __NB__: Not synthesisable +div2BNat :: BNat (2*n) -> BNat n +div2BNat BT = BT +div2BNat (B0 x) = x +div2BNat (B1 _) = error "impossible: 2*n ~ 2*n+1" + +-- | Subtract 1 and divide a base-2 encoded natural number by 2 +-- +-- __NB__: Not synthesisable +div2Sub1BNat :: BNat (2*n+1) -> BNat n +div2Sub1BNat (B1 x) = x +div2Sub1BNat _ = error "impossible: 2*n+1 ~ 2*n" + +-- | Get the log2 of a base-2 encoded natural number +-- +-- __NB__: Not synthesisable +log2BNat :: BNat (2^n) -> BNat n +log2BNat (B1 x) = case stripZeros x of + BT -> BT + _ -> error "impossible: 2^n ~ 2x+1" +log2BNat (B0 x) = succBNat (log2BNat x) + +-- | Strip non-contributing zero's from a base-2 encoded natural number +-- +-- >>> B1 (B0 (B0 (B0 BT))) +-- b1 +-- >>> showBNat (B1 (B0 (B0 (B0 BT)))) +-- "0b0001" +-- >>> showBNat (stripZeros (B1 (B0 (B0 (B0 BT))))) +-- "0b1" +-- >>> stripZeros (B1 (B0 (B0 (B0 BT)))) +-- b1 +-- +-- __NB__: Not synthesisable +stripZeros :: BNat n -> BNat n +stripZeros BT = BT +stripZeros (B1 x) = B1 (stripZeros x) +stripZeros (B0 BT) = BT +stripZeros (B0 x) = case stripZeros x of + BT -> BT + k -> B0 k diff --git a/src/CLaSH/Promoted/Nat/Literals.hs b/src/CLaSH/Promoted/Nat/Literals.hs --- a/src/CLaSH/Promoted/Nat/Literals.hs +++ b/src/CLaSH/Promoted/Nat/Literals.hs @@ -8,11 +8,11 @@ Defines: @ -d0 = snat :: SNat 0 -d1 = snat :: SNat 1 -d2 = snat :: SNat 2 +d0 = SNat :: SNat 0 +d1 = SNat :: SNat 1 +d2 = SNat :: SNat 2 ... -d1024 = snat :: SNat 1024 +d1024 = SNat :: SNat 1024 @ You can generate more 'SNat' literals using 'decLiteralsD' from "CLaSH.Promoted.Nat.TH" 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 @@ -23,10 +23,10 @@ {- $setup >>> :set -XDataKinds ->>> let d1111 = snat :: SNat 1111 ->>> let d1200 = snat :: SNat 1200 ->>> let d1201 = snat :: SNat 1201 ->>> let d1202 = snat :: SNat 1202 +>>> let d1111 = SNat :: SNat 1111 +>>> let d1200 = SNat :: SNat 1200 +>>> let d1201 = SNat :: SNat 1201 +>>> let d1202 = SNat :: SNat 1202 -} -- | Create an 'SNat' literal @@ -42,7 +42,7 @@ let suffix = if n < 0 then error ("Can't make negative SNat: " ++ show n) else show n valName = mkName $ 'd':suffix sig <- sigD valName (appT (conT ''SNat) (litT (numTyLit n))) - val <- valD (varP valName) (normalB [| snat |]) [] + val <- valD (varP valName) (normalB [| SNat |]) [] return [ sig, val ] -- | Create a range of 'SNat' literals diff --git a/src/CLaSH/Promoted/Nat/Unsafe.hs b/src/CLaSH/Promoted/Nat/Unsafe.hs --- a/src/CLaSH/Promoted/Nat/Unsafe.hs +++ b/src/CLaSH/Promoted/Nat/Unsafe.hs @@ -13,9 +13,9 @@ import Data.Reflection (reifyNat) import Unsafe.Coerce (unsafeCoerce) -import CLaSH.Promoted.Nat (SNat (..)) +import CLaSH.Promoted.Nat (SNat, snatProxy) -- | I hope you know what you're doing unsafeSNat :: Integer -> SNat k -unsafeSNat i = reifyNat i (unsafeCoerce . SNat) +unsafeSNat i = reifyNat i $ (\p -> unsafeCoerce (snatProxy p)) {-# NOINLINE unsafeSNat #-} diff --git a/src/CLaSH/Promoted/Ord.hs b/src/CLaSH/Promoted/Ord.hs deleted file mode 100644 --- a/src/CLaSH/Promoted/Ord.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-| -Copyright : (C) 2013-2016, University of Twente -License : BSD2 (see the file LICENSE) -Maintainer : Christiaan Baaij --} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# LANGUAGE Safe #-} - -{-# OPTIONS_HADDOCK show-extensions #-} - -module CLaSH.Promoted.Ord where - -import Data.Type.Bool -import GHC.TypeLits - --- | Type-level 'min' function for natural numbers -type family Min (x :: Nat) (y :: Nat) :: Nat - where - Min x y = If (x <=? y) x y - --- | Type-level 'max' function for natural numbers -type family Max (x :: Nat) (y :: Nat) :: Nat - where - Max x y = If (x <=? y) y x diff --git a/src/CLaSH/Promoted/Symbol.hs b/src/CLaSH/Promoted/Symbol.hs --- a/src/CLaSH/Promoted/Symbol.hs +++ b/src/CLaSH/Promoted/Symbol.hs @@ -13,25 +13,26 @@ {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Promoted.Symbol - (SSymbol (..), ssymbol, ssymbolToString) + (SSymbol (..), ssymbolProxy, ssymbolToString) where -import Data.Proxy import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) -- | Singleton value for a type-level string @s@ -data SSymbol (s :: Symbol) = KnownSymbol s => SSymbol (Proxy s) +data SSymbol (s :: Symbol) where + SSymbol :: KnownSymbol s => SSymbol s instance Show (SSymbol s) where - show (SSymbol s) = symbolVal s + show s@SSymbol = symbolVal s -{-# INLINE ssymbol #-} --- | Create a singleton literal for a type-level natural number -ssymbol :: KnownSymbol s => SSymbol s -ssymbol = SSymbol Proxy +{-# INLINE ssymbolProxy #-} +-- | Create a singleton symbol literal @'SSymbol' s@ from a proxy for +-- /s/ +ssymbolProxy :: KnownSymbol s => proxy s -> SSymbol s +ssymbolProxy _ = SSymbol {-# INLINE ssymbolToString #-} -- | Reify the type-level 'Symbol' @s@ to it's term-level 'String' -- representation. ssymbolToString :: SSymbol s -> String -ssymbolToString (SSymbol s) = symbolVal s +ssymbolToString s@SSymbol = symbolVal s diff --git a/src/CLaSH/Signal.hs b/src/CLaSH/Signal.hs --- a/src/CLaSH/Signal.hs +++ b/src/CLaSH/Signal.hs @@ -8,7 +8,7 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-deprecations #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Signal @@ -17,29 +17,28 @@ -- * Basic circuit functions , signal , register + , registerMaybe , regEn , mux -- * Boolean connectives , (.&&.), (.||.), not1 -- * Product/Signal isomorphism - , Bundle + , Bundle(..) , Unbundled - , bundle - , unbundle -- * Simulation functions (not synthesisable) , simulate , simulateB - -- * Strict versions - , simulate_strict - , simulateB_strict + -- ** lazy versions + , simulate_lazy + , simulateB_lazy -- * List \<-\> Signal conversion (not synthesisable) , sample , sampleN , fromList - -- ** Strict versions - , sample_strict - , sampleN_strict - , fromList_strict + -- ** lazy versions + , sample_lazy + , sampleN_lazy + , fromList_lazy -- * QuickCheck combinators , testFor -- * Type classes @@ -71,6 +70,7 @@ import Control.DeepSeq (NFData) import Data.Bits (Bits) -- Haddock only +import Data.Maybe (isJust, fromJust) import CLaSH.Signal.Internal (Signal', register#, regEn#, (.==.), (./=.), compare1, (.<.), (.<=.), (.>=.), (.>.), fromEnum1, @@ -79,14 +79,13 @@ unsafeShiftL1, shiftR1, unsafeShiftR1, rotateL1, rotateR1, (.||.), (.&&.), not1, mux, sample, sampleN, fromList, simulate, signal, testFor, - sample_strict, sampleN_strict, simulate_strict, - fromList_strict) -import CLaSH.Signal.Explicit (SystemClock, systemClock, simulateB', - simulateB'_strict) + sample_lazy, sampleN_lazy, simulate_lazy, + fromList_lazy) +import CLaSH.Signal.Explicit (SystemClock, systemClock) import CLaSH.Signal.Bundle (Bundle (..), Unbundled') {- $setup ->>> let oscillate = register False (not1 oscillate) +>>> let oscillate = register False (not <$> oscillate) >>> let count = regEn 0 oscillate (count + 1) -} @@ -105,14 +104,19 @@ -- [8,1,2] register :: a -> Signal a -> Signal a register = register# systemClock -infixr `register` +infixr 3 `register` +registerMaybe :: a -> Signal (Maybe a) -> Signal a +registerMaybe initial i = regEn# systemClock initial (fmap isJust i) (fmap fromJust i) +{-# INLINE registerMaybe #-} +infixr 3 `registerMaybe` + {-# INLINE regEn #-} -- | Version of 'register' that only updates its content when its second argument -- is asserted. So given: -- -- @ --- oscillate = 'register' False ('not1' oscillate) +-- oscillate = 'register' False ('not1' '<$>' oscillate) -- count = 'regEn' 0 oscillate (count + 1) -- @ -- @@ -131,51 +135,24 @@ -- 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' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit' --- @ -unbundle :: Bundle a => Signal a -> Unbundled a -unbundle = unbundle' systemClock - -{-# INLINE bundle #-} --- | Example: --- --- @ --- __bundle__ :: ('Signal' a, 'Signal' b) -> 'Signal' (a,b) --- @ +-- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of +-- samples of type @a@ -- --- However: +-- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] +-- [(8,8),(1,1),(2,2),(3,3)... +-- ... -- --- @ --- __bundle__ :: 'Signal' 'CLaSH.Sized.BitVector.Bit' -> 'Signal' 'CLaSH.Sized.BitVector.Bit' --- @ -bundle :: Bundle a => Unbundled a -> Signal a -bundle = bundle' systemClock +-- __NB__: This function is not synthesisable +simulateB :: (Bundle a, Bundle b, NFData a, NFData b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b] +simulateB f = simulate (bundle . f . unbundle) -- | Simulate a (@'Unbundled' a -> 'Unbundled' b@) function given a list of -- samples of type @a@ -- -- >>> simulateB (unbundle . register (8,8) . bundle) [(1,1), (2,2), (3,3)] :: [(Int,Int)] -- [(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 = simulateB' systemClock systemClock - --- | Version of 'simulateB' that strictly evaluates the input elements and the --- output elements --- --- __N.B:__ Exceptions are lazily rethrown -simulateB_strict :: (Bundle a, Bundle b, NFData a, NFData b) - => (Unbundled a -> Unbundled b) -> [a] -> [b] -simulateB_strict = simulateB'_strict systemClock systemClock -{-# DEPRECATED simulateB_strict "'simulateB will be strict in CLaSH 1.0, and 'simulateB_strict' will be removed" #-} +simulateB_lazy :: (Bundle a, Bundle b) => (Unbundled' clk1 a -> Unbundled' clk2 b) -> [a] -> [b] +simulateB_lazy f = simulate_lazy (bundle . f . unbundle) 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 @@ -6,11 +6,12 @@ The Product/Signal isomorphism -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE Trustworthy #-} @@ -25,31 +26,32 @@ import GHC.TypeLits (KnownNat) import Prelude hiding (head, map, tail) -import CLaSH.Signal.Internal (Clock, Signal' (..), SClock) +import CLaSH.Signal.Internal (Clock, Signal' (..)) 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, traverse#, lazyV) +import CLaSH.Sized.RTree (RTree, lazyT) -- | Isomorphism between a 'CLaSH.Signal.Signal' of a product type (e.g. a tuple) and a -- product type of 'CLaSH.Signal.Signal''s. -- --- Instances of 'Bundle' must satisfy the following laws: +-- Instances of 'bundle must satisfy the following laws: -- -- @ --- 'bundle'' . 'unbundle'' = 'id' --- 'unbundle'' . 'bundle'' = 'id' +-- 'bundle' . 'unbundle' = 'id' +-- 'unbundle' . 'bundle' = 'id' -- @ -- --- By default, 'bundle'' and 'unbundle'', are defined as the identity, that is, +-- By default, 'bundle' and 'unbundle', are defined as the identity, that is, -- writing: -- -- @ -- data D = A | B -- --- instance 'Bundle' D +-- instance 'bundle D -- @ -- -- is the same as: @@ -57,47 +59,47 @@ -- @ -- data D = A | B -- --- instance 'Bundle' D where +-- instance 'bundle D where -- type 'Unbundled'' clk D = 'Signal'' clk D --- 'bundle'' _ s = s --- 'unbundle'' _ s = s +-- 'bundle' _ s = s +-- 'unbundle' _ s = s -- @ -- class Bundle a where - type Unbundled' (clk :: Clock) a + type Unbundled' (clk :: Clock) a = res | res -> clk type Unbundled' clk a = Signal' clk a -- | Example: -- -- @ - -- __bundle'__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b) + -- __bundle__ :: ('Signal'' clk a, 'Signal'' clk b) -> 'Signal'' clk (a,b) -- @ -- -- However: -- -- @ - -- __bundle'__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' + -- __bundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -- @ - bundle' :: SClock clk -> Unbundled' clk a -> Signal' clk a + bundle :: Unbundled' clk a -> Signal' clk a - {-# INLINE bundle' #-} - default bundle' :: SClock clk -> Signal' clk a -> Signal' clk a - bundle' _ s = s + {-# INLINE bundle #-} + default bundle :: Signal' clk a -> Signal' clk a + bundle s = s -- | Example: -- -- @ - -- __unbundle'__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b) + -- __unbundle__ :: 'Signal'' clk (a,b) -> ('Signal'' clk a, 'Signal'' clk b) -- @ -- -- However: -- -- @ - -- __unbundle'__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' + -- __unbundle__ :: 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -> 'Signal'' clk 'CLaSH.Sized.BitVector.Bit' -- @ - unbundle' :: SClock clk -> Signal' clk a -> Unbundled' clk a + unbundle :: Signal' clk a -> Unbundled' clk a - {-# INLINE unbundle' #-} - default unbundle' :: SClock clk -> Signal' clk a -> Signal' clk a - unbundle' _ s = s + {-# INLINE unbundle #-} + default unbundle :: Signal' clk a -> Signal' clk a + unbundle s = s instance Bundle Bool instance Bundle Integer @@ -116,93 +118,98 @@ instance Bundle (a,b) where type Unbundled' t (a,b) = (Signal' t a, Signal' t b) - bundle' _ = uncurry (liftA2 (,)) - unbundle' _ tup = (fmap fst tup, fmap snd tup) + bundle = uncurry (liftA2 (,)) + unbundle tup = (fmap fst tup, fmap snd tup) instance Bundle (a,b,c) where type Unbundled' t (a,b,c) = (Signal' t a, Signal' t b, Signal' t c) - bundle' _ (a,b,c) = (,,) <$> a <*> b <*> c - unbundle' _ tup = (fmap (\(x,_,_) -> x) tup - ,fmap (\(_,x,_) -> x) tup - ,fmap (\(_,_,x) -> x) tup - ) + 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) = ( Signal' t a, Signal' t b, Signal' t c , Signal' 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 - ) + 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) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' 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 - ) + 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) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' 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 - ) + 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) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' t f , Signal' 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 - ) + 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) = ( Signal' t a, Signal' t b, Signal' t c , Signal' t d, Signal' t e, Signal' t f , Signal' t g, Signal' 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 - ) + 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 (Signal' t a) -- The 'Traversable' instance of 'Vec' is not synthesisable, so we must - -- define 'bundle'' as a primitive. - bundle' = vecBundle# - unbundle' _ = sequenceA . fmap lazyV + -- define 'bundle' as a primitive. + bundle = vecBundle# + unbundle = sequenceA . fmap lazyV {-# NOINLINE vecBundle# #-} -vecBundle# :: SClock t -> Vec n (Signal' t a) -> Signal' t (Vec n a) -vecBundle# _ = traverse# id +vecBundle# :: Vec n (Signal' t a) -> Signal' t (Vec n a) +vecBundle# = traverse# id + +instance KnownNat d => Bundle (RTree d a) where + type Unbundled' t (RTree d a) = RTree d (Signal' t a) + bundle = sequenceA + unbundle = sequenceA . fmap lazyT diff --git a/src/CLaSH/Signal/Delayed.hs b/src/CLaSH/Signal/Delayed.hs --- a/src/CLaSH/Signal/Delayed.hs +++ b/src/CLaSH/Signal/Delayed.hs @@ -6,9 +6,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -#if __GLASGOW_HASKELL__ > 710 -{-# LANGUAGE DeriveLift #-} -#endif {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} @@ -29,6 +26,8 @@ , toSignal -- * List \<-\> DSignal conversion (not synthesisable) , dfromList + -- ** lazy versions + , dfromList_lazy -- * Experimental , unsafeFromSignal , antiDelay @@ -41,9 +40,9 @@ import CLaSH.Sized.Vector (Vec) import CLaSH.Signal.Explicit (SystemClock, systemClock) -import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, delay', delayI', - feedback, fromSignal, toSignal, - unsafeFromSignal, antiDelay) +import CLaSH.Signal.Delayed.Explicit (DSignal', dfromList, dfromList_lazy, + delay', delayI', feedback, fromSignal, + toSignal, unsafeFromSignal, antiDelay) {- $setup >>> :set -XDataKinds @@ -96,4 +95,3 @@ => DSignal n a -> DSignal (n + d) a delayI = delayI' systemClock - diff --git a/src/CLaSH/Signal/Delayed/Explicit.hs b/src/CLaSH/Signal/Delayed/Explicit.hs --- a/src/CLaSH/Signal/Delayed/Explicit.hs +++ b/src/CLaSH/Signal/Delayed/Explicit.hs @@ -6,9 +6,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -#if __GLASGOW_HASKELL__ > 710 {-# LANGUAGE DeriveLift #-} -#endif {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -35,28 +33,27 @@ , toSignal -- * List \<-\> DSignal conversion (not synthesisable) , dfromList + -- ** lazy versions + , dfromList_lazy -- * Experimental , unsafeFromSignal , antiDelay ) where -import Data.Bits (Bits, FiniteBits) +import Control.DeepSeq (NFData) import Data.Coerce (coerce) import Data.Default (Default(..)) -import Control.Applicative (liftA2) import GHC.TypeLits (KnownNat, Nat, type (+)) import Language.Haskell.TH.Syntax (Lift) import Prelude hiding (head, length, repeat) import Test.QuickCheck (Arbitrary, CoArbitrary) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum) import CLaSH.Promoted.Nat (SNat) import CLaSH.Sized.Vector (Vec, head, length, repeat, shiftInAt0, singleton) -import CLaSH.Signal (fromList) -import CLaSH.Signal.Explicit (Signal', Clock, SClock, register', - bundle', unbundle') +import CLaSH.Signal (fromList, fromList_lazy, bundle, unbundle) +import CLaSH.Signal.Explicit (Signal', Clock, SClock, register') {- $setup >>> :set -XDataKinds @@ -85,19 +82,8 @@ DSignal' { -- | Strip a 'DSignal' from its delay information. toSignal :: Signal' clk a } - deriving (Show,Default,Functor,Applicative,Num,Bounded,Fractional, - Real,Integral,SaturatingNum,Eq,Ord,Enum,Bits,FiniteBits,Foldable, - Traversable,Arbitrary,CoArbitrary,Lift) - -instance ExtendingNum a b - => ExtendingNum (DSignal' clk n a) (DSignal' clk n b) where - type AResult (DSignal' clk n a) (DSignal' clk n b) = - DSignal' clk n (AResult a b) - plus = liftA2 plus - minus = liftA2 minus - type MResult (DSignal' clk n a) (DSignal' clk n b) = - DSignal' clk n (MResult a b) - times = liftA2 times + deriving (Show,Default,Functor,Applicative,Num,Fractional, + Foldable,Traversable,Arbitrary,CoArbitrary,Lift) -- | Create a 'DSignal'' from a list -- @@ -108,9 +94,21 @@ -- [1,2] -- -- __NB__: This function is not synthesisable -dfromList :: [a] -> DSignal' clk 0 a +dfromList :: NFData a => [a] -> DSignal' clk 0 a dfromList = coerce . fromList +-- | Create a 'DSignal' from a list +-- +-- Every element in the list will correspond to a value of the signal for one +-- clock cycle. +-- +-- >>> sampleN 2 (dfromList [1,2,3,4,5]) +-- [1,2] +-- +-- __NB__: This function is not synthesisable +dfromList_lazy :: [a] -> DSignal' clk 0 a +dfromList_lazy = coerce . fromList_lazy + -- | Delay a 'DSignal'' for @d@ periods. -- -- @ @@ -130,8 +128,8 @@ delaySignal :: Signal' clk a -> Signal' clk a delaySignal s = case length m of 0 -> s - _ -> let (r',o) = shiftInAt0 (unbundle' clk r) (singleton s) - r = register' clk m (bundle' clk r') + _ -> let (r',o) = shiftInAt0 (unbundle r) (singleton s) + r = register' clk m (bundle r') in head o -- | Delay a 'DSignal' clk' for @m@ periods, where @m@ is derived from the 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 @@ -10,7 +10,6 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Signal.Explicit @@ -30,24 +29,18 @@ , unsafeSynchronizer -- * Basic circuit functions , register' + , registerMaybe' , regEn' - -- * Product/Signal isomorphism - , Bundle (..) - -- * Simulation functions (not synthesisable) - , simulateB' - -- ** Strict version - , simulateB'_strict ) where -import Control.DeepSeq (NFData) +import Data.Maybe (isJust, fromJust) import GHC.TypeLits (KnownNat, KnownSymbol) -import CLaSH.Promoted.Nat (snat, snatToInteger) -import CLaSH.Promoted.Symbol (ssymbol) +import CLaSH.Promoted.Nat (SNat (..), snatToNum) +import CLaSH.Promoted.Symbol (SSymbol (..)) import CLaSH.Signal.Internal (Signal' (..), Clock (..), SClock (..), register#, - regEn#, simulate, simulate_strict) -import CLaSH.Signal.Bundle (Bundle (..), Unbundled') + regEn#) {- $setup >>> :set -XDataKinds @@ -127,14 +120,14 @@ -- @ sclock :: (KnownSymbol name, KnownNat period) => SClock ('Clk name period) -sclock = SClock ssymbol snat +sclock = SClock SSymbol SNat {-# INLINE withSClock #-} -- | Supply a function with a singleton clock @clk@ according to the context withSClock :: (KnownSymbol name, KnownNat period) => (SClock ('Clk name period) -> a) -> a -withSClock f = f (SClock ssymbol snat) +withSClock f = f (SClock SSymbol SNat) -- | The standard system clock with a period of 1000 type SystemClock = 'Clk "system" 1000 @@ -250,8 +243,8 @@ -> Signal' clk2 a unsafeSynchronizer (SClock _ period1) (SClock _ period2) s = s' where - t1 = fromInteger (snatToInteger period1) - t2 = fromInteger (snatToInteger period2) + t1 = snatToNum period1 + t2 = snatToNum period2 s' | t1 < t2 = compress t2 t1 s | t1 > t2 = oversample t1 t2 s | otherwise = same s @@ -308,8 +301,12 @@ register' :: SClock clk -> a -> Signal' clk a -> Signal' clk a register' = register# +registerMaybe' :: SClock clk -> a -> Signal' clk (Maybe a) -> Signal' clk a +registerMaybe' clk initial i = regEn# clk initial (fmap isJust i) (fmap fromJust i) +{-# INLINE registerMaybe' #-} + {-# INLINE regEn' #-} --- | Version of 'register'' that only updates its content when its second +-- | Version of 'register'' that only updates its content when its third -- argument is asserted. So given: -- -- @ @@ -329,31 +326,3 @@ -- [0,0,1,1,2,2,3,3] regEn' :: SClock clk -> a -> Signal' clk Bool -> Signal' clk a -> Signal' clk a regEn' = regEn# - --- * Simulation functions - --- | Simulate a (@'Unbundled'' clk1 a -> 'Unbundled'' clk2 b@) function given a --- list of samples of type @a@ --- --- >>> simulateB' clkA clkA (unbundle' clkA . register' clkA (8,8) . bundle' clkA) [(1,1), (2,2), (3,3)] :: [(Int,Int)] --- [(8,8),(1,1),(2,2),(3,3)... --- --- __NB__: This function is not synthesisable -simulateB' :: (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] -simulateB' clk1 clk2 f = simulate (bundle' clk2 . f . unbundle' clk1) - --- | Version of 'simulateB'' that strictly evaluates the input elements and the --- output elements --- --- __N.B:__ Exceptions are lazily rethrown -simulateB'_strict :: (Bundle a, Bundle b, NFData a, NFData 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] -simulateB'_strict clk1 clk2 f = simulate_strict (bundle' clk2 . f . unbundle' clk1) -{-# DEPRECATED simulateB'_strict "'simulateB'' will be strict in CLaSH 1.0, and 'simulateB'_strict' will be removed" #-} 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 @@ -19,9 +19,7 @@ -- See: https://github.com/clash-lang/clash-compiler/commit/721fcfa9198925661cd836668705f817bddaae3c -- as to why we need this. -#if __GLASGOW_HASKELL__ > 711 {-# OPTIONS_GHC -fno-cpr-anal #-} -#endif {-# OPTIONS_HADDOCK show-extensions #-} @@ -39,16 +37,16 @@ , (.&&.), (.||.), not1 -- * Simulation functions (not synthesisable) , simulate - -- ** strict versions - , simulate_strict + -- ** lazy version + , simulate_lazy -- * List \<-\> Signal conversion (not synthesisable) , sample , sampleN , fromList - -- ** strict versions - , sample_strict - , sampleN_strict - , fromList_strict + -- ** lazy versions + , sample_lazy + , sampleN_lazy + , fromList_lazy -- * QuickCheck combinators , testFor -- * Type classes @@ -90,9 +88,9 @@ where import Control.Applicative (liftA2, liftA3) -import Control.DeepSeq (NFData,force) -import Control.Exception (SomeException,catch,evaluate,throw) -import Data.Bits (Bits (..), FiniteBits (..)) +import Control.DeepSeq (NFData, force) +import Control.Exception (catch, evaluate, throw) +import Data.Bits (Bits (..)) import Data.Default (Default (..)) import GHC.TypeLits (Nat, Symbol) import Language.Haskell.TH.Syntax (Lift (..)) @@ -100,9 +98,9 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary(..), Property, property) -import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..)) import CLaSH.Promoted.Nat (SNat, snatToInteger) import CLaSH.Promoted.Symbol (SSymbol, ssymbolToString) +import CLaSH.XException (XException, errorX) {- $setup >>> :set -XDataKinds @@ -111,7 +109,7 @@ >>> import CLaSH.Promoted.Symbol >>> type SystemClock = Clk "System" 1000 >>> type Signal a = Signal' SystemClock a ->>> let register = register# (SClock ssymbol snat :: SClock SystemClock) +>>> let register = register# (SClock SSymbol SNat :: SClock SystemClock) -} -- | A clock with a name ('Symbol') and period ('Nat') @@ -261,6 +259,7 @@ -- It is a version of 'not' that operates on 'CLaSH.Signal.Signal's of 'Bool' not1 :: Functor f => f Bool -> f Bool not1 = fmap not +{-# DEPRECATED not1 "'not1' will be removed in clash-prelude-1.0, use \"fmap not\" instead." #-} {-# NOINLINE register# #-} register# :: SClock clk -> a -> Signal' clk a -> Signal' clk a @@ -299,28 +298,6 @@ signal :: Applicative f => a -> f a signal = pure -instance Bounded a => Bounded (Signal' clk a) where - minBound = signal# minBound - maxBound = signal# maxBound - -instance ExtendingNum a b => ExtendingNum (Signal' clk a) (Signal' clk b) where - type AResult (Signal' clk a) (Signal' clk b) = Signal' clk (AResult a b) - plus = liftA2 plus - minus = liftA2 minus - type MResult (Signal' clk a) (Signal' clk b) = Signal' clk (MResult a b) - times = liftA2 times - -instance SaturatingNum a => SaturatingNum (Signal' 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 (Signal' clk a) where - (==) = error "(==)' undefined for 'Signal'', use '(.==.)' instead" - (/=) = error "(/=)' undefined for 'Signal'', use '(./=.)' instead" - infix 4 .==. -- | The above type is a generalisation for: -- @@ -343,17 +320,6 @@ (./=.) :: (Eq a, Applicative f) => f a -> f a -> f Bool (./=.) = liftA2 (/=) --- | __WARNING__: 'compare', ('<'), ('>='), ('>'), and ('<=') are --- undefined, use 'compare1', ('.<.'), ('.>=.'), ('.>.'), and ('.<=.') instead -instance Ord a => Ord (Signal' clk a) where - compare = error "'compare' undefined for 'Signal'', use 'compare1' instead" - (<) = error "'(<)' undefined for 'Signal'', use '(.<.)' instead" - (>=) = error "'(>=)' undefined for 'Signal'', use '(.>=.)' instead" - (>) = error "'(>)' undefined for 'Signal'', use '(.>.)' instead" - (<=) = error "'(<=)' undefined for 'Signal'', use '(.<=.)' instead" - max = liftA2 max - min = liftA2 min - -- | The above type is a generalisation for: -- -- @ @@ -363,6 +329,7 @@ -- It is a version of 'compare' that returns a 'CLaSH.Signal.Signal' of 'Ordering' compare1 :: (Ord a, Applicative f) => f a -> f a -> f Ordering compare1 = liftA2 compare +{-# DEPRECATED compare1 "'compare1' will be removed in clash-prelude-1.0, use \"liftA2 compare\" instead." #-} infix 4 .<. -- | The above type is a generalisation for: @@ -408,17 +375,6 @@ (.>=.) :: (Ord a, Applicative f) => f a -> f a -> f Bool (.>=.) = liftA2 (>=) --- | __WARNING__: 'fromEnum' is undefined, use 'fromEnum1' instead -instance Enum a => Enum (Signal' clk a) where - succ = fmap succ - pred = fmap pred - toEnum = signal# . toEnum - fromEnum = error "'fromEnum' undefined for 'Signal'', use 'fromEnum1'" - enumFrom = sequenceA . fmap enumFrom - enumFromThen = (sequenceA .) . liftA2 enumFromThen - enumFromTo = (sequenceA .) . liftA2 enumFromTo - enumFromThenTo = ((sequenceA .) .) . liftA3 enumFromThenTo - -- | The above type is a generalisation for: -- -- @ @@ -428,10 +384,7 @@ -- It is a version of 'fromEnum' that returns a CLaSH.Signal.Signal' of 'Int' fromEnum1 :: (Enum a, Functor f) => f a -> f Int fromEnum1 = fmap fromEnum - --- | __WARNING__: 'toRational' is undefined, use 'toRational1' instead -instance (Num a, Ord a) => Real (Signal' clk a) where - toRational = error "'toRational' undefined for 'Signal'', use 'toRational1'" +{-# DEPRECATED fromEnum1 "'fromEnum1' will be removed in clash-prelude-1.0, use \"fmap fromEnum\" instead." #-} -- | The above type is a generalisation for: -- @@ -442,16 +395,7 @@ -- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Rational' toRational1 :: (Real a, Functor f) => f a -> f Rational toRational1 = fmap toRational - --- | __WARNING__: 'toInteger' is undefined, use 'toInteger1' instead -instance Integral a => Integral (Signal' 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 'Signal'', use 'toInteger1'" +{-# DEPRECATED toRational1 "'toRational1' will be removed in clash-prelude-1.0, use \"fmap toRational\" instead." #-} -- | The above type is a generalisation for: -- @@ -462,34 +406,7 @@ -- It is a version of 'toRational' that returns a 'CLaSH.Signal.Signal' of 'Integer' toInteger1 :: (Integral a, Functor f) => f a -> f Integer toInteger1 = fmap toInteger - --- | __WARNING__: 'testBit' and 'popCount' are undefined, use 'testBit1' and --- 'popCount1' instead -instance Bits a => Bits (Signal' 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 'Signal'', use 'testbit1'" - bitSizeMaybe _ = bitSizeMaybe (undefined :: a) - bitSize _ = maybe 0 id (bitSizeMaybe (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 'Signal'', use 'popCount1'" - -instance FiniteBits a => FiniteBits (Signal' clk a) where - finiteBitSize _ = finiteBitSize (undefined :: a) +{-# DEPRECATED toInteger1 "'toInteger1' will be removed in clash-prelude-1.0, use \"fmap toInteger\" instead." #-} -- | The above type is a generalisation for: -- @@ -501,6 +418,7 @@ -- argument, and a result of 'CLaSH.Signal.Signal' of 'Bool' testBit1 :: (Bits a, Applicative f) => f a -> f Int -> f Bool testBit1 = liftA2 testBit +{-# DEPRECATED testBit1 "'testBit1' will be removed in clash-prelude-1.0, use \"liftA2 testBit\" instead." #-} -- | The above type is a generalisation for: -- @@ -511,6 +429,7 @@ -- It is a version of 'popCount' that returns a 'CLaSH.Signal.Signal' of 'Int' popCount1 :: (Bits a, Functor f) => f a -> f Int popCount1 = fmap popCount +{-# DEPRECATED popCount1 "'popCount1' will be removed in clash-prelude-1.0, use \"fmap popCount\" instead." #-} -- | The above type is a generalisation for: -- @@ -521,6 +440,7 @@ -- It is a version of 'shift' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shift1 :: (Bits a, Applicative f) => f a -> f Int -> f a shift1 = liftA2 shift +{-# DEPRECATED shift1 "'shift1' will be removed in clash-prelude-1.0, use \"liftA2 shift\" instead." #-} -- | The above type is a generalisation for: -- @@ -531,6 +451,7 @@ -- It is a version of 'rotate' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotate1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotate1 = liftA2 rotate +{-# DEPRECATED rotate1 "'rotate1' will be removed in clash-prelude-1.0, use \"liftA2 rotate\" instead." #-} -- | The above type is a generalisation for: -- @@ -541,6 +462,7 @@ -- It is a version of 'setBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument setBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a setBit1 = liftA2 setBit +{-# DEPRECATED setBit1 "'setBit1' will be removed in clash-prelude-1.0, use \"liftA2 setBit\" instead." #-} -- | The above type is a generalisation for: -- @@ -551,6 +473,7 @@ -- It is a version of 'clearBit' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument clearBit1 :: (Bits a, Applicative f) => f a -> f Int -> f a clearBit1 = liftA2 clearBit +{-# DEPRECATED clearBit1 "'clearBit1' will be removed in clash-prelude-1.0, use \"liftA2 clearBit\" instead." #-} -- | The above type is a generalisation for: -- @@ -561,6 +484,7 @@ -- It is a version of 'shiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a shiftL1 = liftA2 shiftL +{-# DEPRECATED shiftL1 "'shiftL1' will be removed in clash-prelude-1.0, use \"liftA2 shiftL\" instead." #-} -- | The above type is a generalisation for: -- @@ -571,6 +495,7 @@ -- It is a version of 'unsafeShiftL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument unsafeShiftL1 :: (Bits a, Applicative f) => f a -> f Int -> f a unsafeShiftL1 = liftA2 unsafeShiftL +{-# DEPRECATED unsafeShiftL1 "'unsafeShiftL1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftL\" instead." #-} -- | The above type is a generalisation for: -- @@ -581,6 +506,7 @@ -- It is a version of 'shiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument shiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a shiftR1 = liftA2 shiftR +{-# DEPRECATED shiftR1 "'shiftR1' will be removed in clash-prelude-1.0, use \"liftA2 shiftR\" instead." #-} -- | The above type is a generalisation for: -- @@ -591,6 +517,7 @@ -- It is a version of 'unsafeShiftR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument unsafeShiftR1 :: (Bits a, Applicative f) => f a -> f Int -> f a unsafeShiftR1 = liftA2 unsafeShiftR +{-# DEPRECATED unsafeShiftR1 "'unsafeShiftR1' will be removed in clash-prelude-1.0, use \"liftA2 unsafeShiftR\" instead." #-} -- | The above type is a generalisation for: -- @@ -601,6 +528,7 @@ -- It is a version of 'rotateL' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotateL1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotateL1 = liftA2 rotateL +{-# DEPRECATED rotateL1 "'rotateL1' will be removed in clash-prelude-1.0, use \"liftA2 rotateL\" instead." #-} -- | The above type is a generalisation for: -- @@ -611,6 +539,7 @@ -- It is a version of 'rotateR' that has a 'CLaSH.Signal.Signal' of 'Int' as indexing argument rotateR1 :: (Bits a, Applicative f) => f a -> f Int -> f a rotateR1 = liftA2 rotateR +{-# DEPRECATED rotateR1 "'rotateR1' will be removed in clash-prelude-1.0, use \"liftA2 rotateR\" instead." #-} instance Fractional a => Fractional (Signal' clk a) where (/) = liftA2 (/) @@ -623,7 +552,7 @@ instance CoArbitrary a => CoArbitrary (Signal' clk a) where coarbitrary xs gen = do n <- arbitrary - coarbitrary (take (abs n) (sample xs)) gen + coarbitrary (take (abs n) (sample_lazy xs)) gen -- | The above type is a generalisation for: -- @@ -637,6 +566,16 @@ -- * List \<-\> Signal conversion (not synthesisable) +-- | A 'force' that lazily returns exceptions +forceNoException :: NFData a => a -> IO a +forceNoException x = catch (evaluate (force x)) (\(e :: XException) -> return (throw e)) + +headStrictCons :: NFData a => a -> [a] -> [a] +headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs) + +headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a +headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs) + -- | The above type is a generalisation for: -- -- @ @@ -651,8 +590,8 @@ -- > sample s == [s0, s1, s2, s3, ... -- -- __NB__: This function is not synthesisable -sample :: Foldable f => f a -> [a] -sample = foldr (:) [] +sample :: (Foldable f, NFData a) => f a -> [a] +sample = foldr headStrictCons [] -- | The above type is a generalisation for: -- @@ -668,7 +607,7 @@ -- > sampleN 3 s == [s0, s1, s2] -- -- __NB__: This function is not synthesisable -sampleN :: Foldable f => Int -> f a -> [a] +sampleN :: (Foldable f, NFData a) => Int -> f a -> [a] sampleN n = take n . sample -- | Create a 'CLaSH.Signal.Signal' from a list @@ -680,8 +619,8 @@ -- [1,2] -- -- __NB__: This function is not synthesisable -fromList :: [a] -> Signal' clk a -fromList = Prelude.foldr (:-) (error "finite list") +fromList :: NFData a => [a] -> Signal' clk a +fromList = Prelude.foldr headStrictSignal (errorX "finite list") -- * Simulation functions (not synthesisable) @@ -690,47 +629,67 @@ -- -- >>> simulate (register 8) [1, 2, 3] -- [8,1,2,3... +-- ... -- -- __NB__: This function is not synthesisable -simulate :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] +simulate :: (NFData a, NFData b) => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] simulate f = sample . f . fromList --- | A 'force' that lazily returns exceptions -forceNoException :: NFData a => a -> IO a -forceNoException x = catch (evaluate (force x)) (\(e :: SomeException) -> return (throw e)) - -headStrictCons :: NFData a => a -> [a] -> [a] -headStrictCons x xs = unsafeDupablePerformIO ((:) <$> forceNoException x <*> pure xs) - -headStrictSignal :: NFData a => a -> Signal' clk a -> Signal' clk a -headStrictSignal x xs = unsafeDupablePerformIO ((:-) <$> forceNoException x <*> pure xs) - --- | Version of 'sample' that strictly evaluates the samples +-- | The above type is a generalisation for: -- --- __N.B:__ Exceptions are lazily rethrown -sample_strict :: (Foldable f, NFData a) => f a -> [a] -sample_strict = foldr headStrictCons [] -{-# DEPRECATED sample_strict "'sample' will be strict in CLaSH 1.0, and 'sample_strict' will be removed" #-} +-- @ +-- __sample__ :: 'CLaSH.Signal.Signal' a -> [a] +-- @ +-- +-- Get an infinite list of samples from a 'CLaSH.Signal.Signal' +-- +-- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' +-- at consecutive clock cycles +-- +-- > sample s == [s0, s1, s2, s3, ... +-- +-- __NB__: This function is not synthesisable +sample_lazy :: Foldable f => f a -> [a] +sample_lazy = foldr (:) [] --- | Version of 'sampleN' that strictly evaluates the samples +-- | The above type is a generalisation for: -- --- __N.B:__ Exceptions are lazily rethrown -sampleN_strict :: (Foldable f, NFData a) => Int -> f a -> [a] -sampleN_strict n = take n . sample_strict -{-# DEPRECATED sampleN_strict "'sampleN' will be strict in CLaSH 1.0, and 'sampleN_strict' will be removed" #-} +-- @ +-- __sampleN__ :: Int -> 'CLaSH.Signal.Signal' a -> [a] +-- @ +-- +-- Get a list of @n@ samples from a 'CLaSH.Signal.Signal' +-- +-- The elements in the list correspond to the values of the 'CLaSH.Signal.Signal' +-- at consecutive clock cycles +-- +-- > sampleN 3 s == [s0, s1, s2] +-- +-- __NB__: This function is not synthesisable +sampleN_lazy :: Foldable f => Int -> f a -> [a] +sampleN_lazy n = take n . sample_lazy --- | Version of 'fromList' that strictly evaluates the elements of the list +-- | Create a 'CLaSH.Signal.Signal' from a list -- --- __N.B:__ Exceptions are lazily rethrown -fromList_strict :: NFData a => [a] -> Signal' clk a -fromList_strict = foldr headStrictSignal (error "finite list") -{-# DEPRECATED fromList_strict "'fromList' will be strict in CLaSH 1.0, and 'fromList_strict' will be removed" #-} +-- 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_lazy :: [a] -> Signal' clk a +fromList_lazy = Prelude.foldr (:-) (error "finite list") --- | Version of 'simulate' that strictly evaluates the input elements and the --- output elements +-- * Simulation functions (not synthesisable) + +-- | Simulate a (@'CLaSH.Signal.Signal' a -> 'CLaSH.Signal.Signal' b@) function +-- given a list of samples of type @a@ -- --- __N.B:__ Exceptions are lazily rethrown -simulate_strict :: (NFData a, NFData b) - => (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] -simulate_strict f = sample_strict . f . fromList_strict -{-# DEPRECATED simulate_strict "'simulate' will be strict in CLaSH 1.0, and 'simulate_strict' will be removed" #-} +-- >>> simulate (register 8) [1, 2, 3] +-- [8,1,2,3... +-- ... +-- +-- __NB__: This function is not synthesisable +simulate_lazy :: (Signal' clk1 a -> Signal' clk2 b) -> [a] -> [b] +simulate_lazy f = sample_lazy . f . fromList_lazy 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 @@ -32,12 +32,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Fixed @@ -79,6 +81,7 @@ import Data.Ratio ((%), denominator, numerator) import Data.Typeable (Typeable, TypeRep, typeRep) import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, mkName, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) @@ -90,9 +93,12 @@ boundedMult) import CLaSH.Class.Resize (Resize (..)) import CLaSH.Promoted.Nat (SNat) -import CLaSH.Promoted.Ord (Max) +import CLaSH.Prelude.BitIndex (msb, split) +import CLaSH.Prelude.BitReduction (reduceAnd, reduceOr) +import CLaSH.Sized.BitVector (BitVector, (++#)) import CLaSH.Sized.Signed (Signed) import CLaSH.Sized.Unsigned (Unsigned) +import CLaSH.XException (ShowX (..), showsPrecXWith) {- $setup >>> :set -XDataKinds @@ -258,6 +264,10 @@ else fRepI .&. ((2 ^ nF) - 1) denom = 2 ^ nF +instance ( size ~ (int + frac), KnownNat frac, Integral (rep size) + ) => ShowX (Fixed rep int frac) where + showsPrecX = showsPrecXWith showsPrec + -- | None of the 'Read' class' methods are synthesisable. instance (size ~ (int + frac), KnownNat frac, Bounded (rep size), Integral (rep size)) => Read (Fixed rep int frac) where @@ -346,26 +356,30 @@ -- | 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)) + = ( Bounded (rep ((1 + Max int1 int2) + Max frac1 frac2)) , Num (rep ((1 + Max int1 int2) + Max frac1 frac2)) + , Bits (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)) + , KnownNat int1 + , KnownNat int2 + , KnownNat frac1 + , KnownNat frac2 + , Resize rep ) -- | Constraint for the 'ExtendingNum' instance of 'SFixed' type ENumSFixedC int1 frac1 int2 frac2 - = ( KnownNat frac1 - , KnownNat frac2 + = ( KnownNat (int2 + frac2) + , KnownNat (1 + Max int1 int2 + Max frac1 frac2) , KnownNat (Max frac1 frac2) + , KnownNat (1 + Max int1 int2) , 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)) + , KnownNat frac2 + , KnownNat int2 + , KnownNat frac1 + , KnownNat int1 ) -- | Constraint for the 'ExtendingNum' instance of 'UFixed' @@ -383,13 +397,17 @@ 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) + plus (Fixed f1) (Fixed f2) = + let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int + f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) + sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int + f2R = shiftL (resize f2) sh2 :: 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) + minus (Fixed f1) (Fixed f2) = + let sh1 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac1)) :: Int + f1R = shiftL (resize f1) sh1 :: rep ((1 + Max int1 int2) + (Max frac1 frac2)) + sh2 = fromInteger (natVal (Proxy @(Max frac1 frac2)) - natVal (Proxy @frac2)) :: Int + f2R = shiftL (resize f2) sh2 :: 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) @@ -399,20 +417,31 @@ 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)) + , BitSize (rep ((int + int) + (frac + frac))) ~ + (int + ((int + frac) + frac)) + , BitPack (rep ((int + int) + (frac + frac))) + , Bits (rep ((int + int) + (frac + frac))) + , KnownNat (BitSize (rep (int + frac))) + , BitPack (rep (int + frac)) + , Enum (rep (int + frac)) + , Bits (rep (int + frac)) + , Resize rep + , KnownNat int + , KnownNat frac ) -- | Constraint for the 'Num' instance of 'SFixed' type NumSFixedC int frac = - ( KnownNat frac + ( KnownNat ((int + int) + (frac + frac)) , KnownNat (frac + frac) + , KnownNat (int + int) , KnownNat (int + frac) - , KnownNat (1 + (int + frac)) - , KnownNat ((int + frac) + (int + frac)) - , ((int + int) + (frac + frac)) ~ ((int + frac) + (int + frac)) + , KnownNat frac + , KnownNat int ) + -- | Constraint for the 'Num' instance of 'UFixed' type NumUFixedC int frac = NumSFixedC int frac @@ -434,7 +463,7 @@ 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)) + fromInteger i = let fSH = fromInteger (natVal (Proxy @frac)) res = Fixed (fromInteger i `shiftL` fSH) in res @@ -464,18 +493,21 @@ , Num (rep (int1 + frac1)) , Bits (rep (int1 + frac1)) , Bits (rep (int2 + frac2)) + , Bounded (rep (int2 + frac2)) + , KnownNat int1 , KnownNat frac1 + , KnownNat int2 , KnownNat frac2 - , KnownNat (int1 + frac1) - , KnownNat (int2 + frac2) ) -- | Constraint for the 'resizeF' function, specialized for 'SFixed' type ResizeSFC int1 frac1 int2 frac2 - = ( KnownNat frac1 + = ( KnownNat int1 + , KnownNat frac1 + , KnownNat int2 , KnownNat frac2 - , KnownNat (int1 + frac1) , KnownNat (int2 + frac2) + , KnownNat (int1 + frac1) ) -- | Constraint for the 'resizeF' function, specialized for 'UFixed' @@ -507,24 +539,18 @@ -- -- * @'ResizeUFC' rep int1 frac1 int2 frac2@ for: -- @'UFixed' int1 frac1 -> 'UFixed' int2 frac2@ -resizeF ::(ResizeFC rep int1 frac1 int2 frac2, Bounded (rep (int2 + frac2))) +resizeF :: forall rep int1 frac1 int2 frac2 . ResizeFC rep int1 frac1 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 +resizeF (Fixed fRep) = Fixed sat where - argSZ = natVal (Proxy :: Proxy (int1 + frac1)) - resSZ = natVal (Proxy :: Proxy (int2 + frac2)) + fMin = minBound :: rep (int2 + frac2) + fMax = maxBound :: rep (int2 + frac2) + argSZ = natVal (Proxy @(int1 + frac1)) + resSZ = natVal (Proxy @(int2 + frac2)) - argFracSZ = fromInteger (natVal (Proxy :: Proxy frac1)) - resFracSZ = fromInteger (natVal (Proxy :: Proxy frac2)) + argFracSZ = fromInteger (natVal (Proxy @frac1)) + resFracSZ = fromInteger (natVal (Proxy @frac2)) -- All size and frac comparisons and related if-then-else statements should -- be optimized away by the compiler @@ -540,7 +566,7 @@ (resFracSZ - argFracSZ) shiftedL_masked = shiftedL .&. mask shiftedL_resized = resize shiftedL - in if doWrap then shiftedL_resized else if fRep >= 0 + in if fRep >= 0 then if shiftedL_masked == 0 then shiftedL_resized else fMax @@ -551,7 +577,7 @@ (argFracSZ - resFracSZ) shiftedR_masked = shiftedR .&. mask shiftedR_resized = resize shiftedR - in if doWrap then shiftedR_resized else if fRep >= 0 + in if fRep >= 0 then if shiftedR_masked == 0 then shiftedR_resized else fMax @@ -608,7 +634,7 @@ then rMin else truncated truncated = truncate shifted :: Integer - shifted = a * (2 ^ (natVal (Proxy :: Proxy frac))) + shifted = a * (2 ^ (natVal (Proxy @frac))) -- | Convert, at run-time, a 'Double' to a 'Fixed'-point. -- @@ -660,7 +686,7 @@ -- We then compile this to an executable: -- -- @ --- $ clash --make createRomFile.hs +-- \$ clash --make createRomFile.hs -- @ -- -- We can then use this utility to convert our @Data.txt@ file which contains @@ -668,7 +694,7 @@ -- binary data: -- -- @ --- $ ./createRomFile \"Data.txt\" \"Data.bin\" +-- \$ ./createRomFile \"Data.txt\" \"Data.bin\" -- @ -- -- Which results in a @Data.bin@ file containing: @@ -773,41 +799,82 @@ then rMin else truncated truncated = truncate shifted :: Integer - shifted = a * (2 ^ (natVal (Proxy :: Proxy frac))) + shifted = a * (2 ^ (natVal (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 + satMult SatWrap (Fixed a) (Fixed b) = + let res = a `times` b + sh = fromInteger (natVal (Proxy @frac)) + res' = shiftR res sh + in Fixed (resize res') + + satMult SatBound (Fixed a) (Fixed b) = + let res = a `times` b + sh = fromInteger (natVal (Proxy @frac)) + (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) + in case isSigned a of + True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack (resize (shiftR rR sh)) + _ -> case msb rL of + 0 -> maxBound + _ -> minBound + False -> case rL of + 0 -> unpack (resize (shiftR rR sh)) + _ -> maxBound + + satMult SatZero (Fixed a) (Fixed b) = + let res = a `times` b + sh = fromInteger (natVal (Proxy @frac)) + (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) + in case isSigned a of + True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack (resize (shiftR rR sh)) + _ -> 0 + False -> case rL of + 0 -> unpack (resize (shiftR rR sh)) + _ -> 0 + + satMult SatSymmetric (Fixed a) (Fixed b) = + let res = a `times` b + sh = fromInteger (natVal (Proxy @frac)) + (rL,rR) = split res :: (BitVector int, BitVector (int + frac + frac)) + in case isSigned a of + True -> let overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack (resize (shiftR rR sh)) + _ -> case msb rL of + 0 -> maxBound + _ -> succ minBound + False -> case rL of + 0 -> unpack (resize (shiftR rR sh)) + _ -> maxBound + -- | 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 int1 + , KnownNat 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 (((int1 + frac2) + 1) + (int2 + frac1)) , KnownNat frac2 - , KnownNat (int1 + frac1) - , KnownNat (int2 + frac2) - , KnownNat ((int1 + frac2 + 1) + (int2 + frac1)) + , KnownNat int2 + , KnownNat frac1 + , KnownNat int1 ) -- | Constraint for the 'divide' function, specialized for 'UFixed' @@ -831,26 +898,27 @@ => 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' +divide (Fixed fr1) fx2@(Fixed fr2) = + let int2 = fromInteger (natVal (asIntProxy fx2)) + frac2 = fromInteger (natVal fx2) + fr1' = resize fr1 + fr2' = resize fr2 + fr1SH = shiftL fr1' ((int2 + frac2)) + res = fr1SH `quot` fr2' + in Fixed res -- | 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)) + , KnownNat int + , KnownNat frac ) -- | Constraint for the 'Fractional' instance of 'SFixed' type FracSFixedC int frac = ( NumSFixedC int frac - , KnownNat int , KnownNat ((int + frac + 1) + (int + frac)) ) @@ -868,7 +936,7 @@ -- * @'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 +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 diff --git a/src/CLaSH/Sized/Index.hs b/src/CLaSH/Sized/Index.hs --- a/src/CLaSH/Sized/Index.hs +++ b/src/CLaSH/Sized/Index.hs @@ -4,14 +4,13 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK show-extensions #-} @@ -22,6 +21,7 @@ import GHC.TypeLits (KnownNat, type (^)) import GHC.TypeLits.Extra (CLog) -- documentation only +import CLaSH.Promoted.Nat (SNat (..), pow2SNat) import CLaSH.Sized.BitVector (BitVector) import CLaSH.Sized.Internal.Index @@ -42,5 +42,5 @@ -- -- 'bv2i' on the other hand will /never/ fail at run-time, because the -- 'BitVector' argument determines the size. -bv2i :: KnownNat (2^n) => BitVector n -> Index (2^n) +bv2i :: KnownNat n => BitVector n -> Index (2^n) bv2i = unpack# 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 @@ -4,20 +4,22 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.BitVector @@ -88,6 +90,9 @@ , rotateL# , rotateR# , popCountBV + -- ** FiniteBits + , countLeadingZerosBV + , countTrailingZerosBV -- ** Resize , resize# -- ** QuickCheck @@ -106,6 +111,7 @@ import GHC.Integer (smallInteger) import GHC.Prim (dataToTag#) import GHC.TypeLits (KnownNat, Nat, type (+), type (-), natVal) +import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (Q, TExp, TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Numeric (readInt) @@ -116,8 +122,8 @@ import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), SaturationMode (..)) import CLaSH.Class.Resize (Resize (..)) -import CLaSH.Promoted.Nat (SNat, snatToInteger) -import CLaSH.Promoted.Ord (Max) +import CLaSH.Promoted.Nat (SNat, snatToInteger, snatToNum) +import CLaSH.XException (ShowX (..), showsPrecXWith) import {-# SOURCE #-} qualified CLaSH.Sized.Vector as V import {-# SOURCE #-} qualified CLaSH.Sized.Internal.Index as I @@ -137,7 +143,7 @@ -- | The constructor, 'BV', and the field, 'unsafeToInteger', are not -- synthesisable. BV { unsafeToInteger :: Integer} - deriving Data + deriving (Data) -- | 'Bit': a 'BitVector' of length 1 type Bit = BitVector 1 @@ -163,6 +169,9 @@ (rest,_) -> rest {-# NOINLINE show #-} +instance KnownNat n => ShowX (BitVector n) where + showsPrecX = showsPrecXWith showsPrec + -- | Create a binary literal -- -- >>> $$(bLit "1001") :: BitVector 4 @@ -236,12 +245,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: BitVector n -> [BitVector n] -enumFromThen# :: BitVector n -> BitVector n -> [BitVector n] +enumFrom# :: KnownNat n => BitVector n -> [BitVector n] +enumFromThen# :: KnownNat n => BitVector n -> BitVector n -> [BitVector n] enumFromTo# :: BitVector n -> BitVector n -> [BitVector n] enumFromThenTo# :: BitVector n -> BitVector n -> BitVector n -> [BitVector n] -enumFrom# x = map BV [unsafeToInteger x ..] -enumFromThen# x y = map BV [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map BV [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map BV [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -254,8 +263,9 @@ minBound# = BV 0 {-# NOINLINE maxBound# #-} -maxBound# :: KnownNat n => BitVector n -maxBound# = let res = BV ((2 ^ natVal res) - 1) in res +maxBound# :: forall n . KnownNat n => BitVector n +maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + in BV (m-1) instance KnownNat n => Num (BitVector n) where (+) = (+#) @@ -266,21 +276,26 @@ signum bv = resize# (reduceOr# bv) fromInteger = fromInteger# -(+#),(-#),(*#) :: KnownNat n => BitVector n -> BitVector n -> BitVector n +(+#),(-#),(*#) :: forall n . KnownNat n => BitVector n -> BitVector n -> BitVector n {-# NOINLINE (+#) #-} -(+#) (BV i) (BV j) = fromInteger_INLINE (i + j) +(+#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + z = i + j + in if z >= m then BV (z - m) else BV z {-# NOINLINE (-#) #-} -(-#) (BV i) (BV j) = fromInteger_INLINE (i - j) +(-#) (BV i) (BV j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + z = i - j + in if z < 0 then BV (m + z) else BV z {-# NOINLINE (*#) #-} (*#) (BV i) (BV j) = fromInteger_INLINE (i * j) {-# NOINLINE negate# #-} -negate# :: KnownNat n => BitVector n -> BitVector n -negate# bv@(BV i) = sz `seq` BV (sz - i) +negate# :: forall n . KnownNat n => BitVector n -> BitVector n +negate# (BV 0) = BV 0 +negate# (BV i) = BV (sz - i) where - sz = 2 ^ natVal bv + sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> BitVector n @@ -288,29 +303,33 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> BitVector n -fromInteger_INLINE i = sz `seq` BV (i `mod` (shiftL 1 sz)) +fromInteger_INLINE i = sz `seq` BV (i `mod` sz) where - sz = fromInteger (natVal (Proxy :: Proxy n)) + sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) -instance (KnownNat (Max m n + 1), KnownNat (m + n)) => - ExtendingNum (BitVector m) (BitVector n) where +instance (KnownNat m, KnownNat 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) +plus# :: BitVector m -> BitVector n -> BitVector (Max m n + 1) +plus# (BV a) (BV b) = BV (a + b) {-# NOINLINE minus# #-} -minus# (BV a) (BV b) = fromInteger_INLINE (a - b) +minus# :: forall m n . (KnownNat m, KnownNat n) => BitVector m -> BitVector n + -> BitVector (Max m n + 1) +minus# (BV a) (BV b) = + let sz = fromInteger (natVal (Proxy @(Max m n + 1))) + mask = 1 `shiftL` sz + z = a - b + in if z < 0 then BV (mask + z) else BV z {-# NOINLINE times# #-} -times# :: KnownNat (m + n) => BitVector m -> BitVector n -> BitVector (m + n) -times# (BV a) (BV b) = fromInteger_INLINE (a * b) +times# :: BitVector m -> BitVector n -> BitVector (m + n) +times# (BV a) (BV b) = BV (a * b) instance KnownNat n => Real (BitVector n) where toRational = toRational . toInteger# @@ -334,7 +353,7 @@ toInteger# :: BitVector n -> Integer toInteger# (BV i) = i -instance (KnownNat n, KnownNat (n+1), KnownNat (n+2)) => Bits (BitVector n) where +instance KnownNat n => Bits (BitVector n) where (.&.) = and# (.|.) = or# xor = xor# @@ -352,13 +371,23 @@ shiftR v i = shiftR# v i rotateL v i = rotateL# v i rotateR v i = rotateR# v i - popCount bv = fromEnum (popCountBV (bv ++# (0 :: Bit))) + popCount bv = fromInteger (I.toInteger# (popCountBV (bv ++# (0 :: Bit)))) -instance (KnownNat n, KnownNat (n+1), KnownNat (n+2)) => FiniteBits (BitVector n) where - finiteBitSize = size# +instance KnownNat n => FiniteBits (BitVector n) where + finiteBitSize = size# + countLeadingZeros = fromInteger . I.toInteger# . countLeadingZerosBV + countTrailingZeros = fromInteger . I.toInteger# . countTrailingZerosBV +countLeadingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1) +countLeadingZerosBV = V.foldr (\l r -> if eq# l low then 1 + r else 0) 0 . V.bv2v +{-# INLINE countLeadingZerosBV #-} + +countTrailingZerosBV :: KnownNat n => BitVector n -> I.Index (n+1) +countTrailingZerosBV = V.foldl (\l r -> if eq# r low then 1 + l else 0) 0 . V.bv2v +{-# INLINE countTrailingZerosBV #-} + {-# NOINLINE reduceAnd# #-} -reduceAnd# :: (KnownNat n) => BitVector n -> BitVector 1 +reduceAnd# :: KnownNat n => BitVector n -> BitVector 1 reduceAnd# bv@(BV i) = BV (smallInteger (dataToTag# check)) where check = i == maxI @@ -408,10 +437,10 @@ {-# 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) +msb# :: forall n . KnownNat n => BitVector n -> Bit +msb# (BV v) + = let i = fromInteger (natVal (Proxy @n) - 1) + in BV (smallInteger (dataToTag# (testBit v i))) {-# NOINLINE lsb# #-} -- | LSB @@ -423,7 +452,7 @@ slice# (BV i) m n = BV (shiftR (i .&. mask) n') where m' = snatToInteger m - n' = fromInteger (snatToInteger n) + n' = snatToNum n mask = 2 ^ (m' + 1) - 1 @@ -474,13 +503,16 @@ 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) +split# :: forall n m . KnownNat n + => BitVector (m + n) -> (BitVector m, BitVector n) +split# (BV i) = (BV l, BV r) where - n = fromInteger (natVal r) - mask = (2 ^ n) - 1 - r = BV (i .&. mask) - l = BV (i `shiftR` n) + n = fromInteger (natVal (Proxy @n)) + mask = 1 `shiftL` n + -- The code below is faster than: + -- > (l,r) = i `divMod` mask + r = i `mod` mask + l = i `shiftR` n and#, or#, xor# :: BitVector n -> BitVector n -> BitVector n {-# NOINLINE and# #-} @@ -496,8 +528,9 @@ 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 +shiftL#, rotateL#, rotateR# :: KnownNat n + => BitVector n -> Int -> BitVector n + {-# NOINLINE shiftL# #-} shiftL# (BV v) i | i < 0 = error @@ -505,10 +538,11 @@ | otherwise = fromInteger_INLINE (shiftL v i) {-# NOINLINE shiftR# #-} +shiftR# :: BitVector n -> Int -> BitVector n shiftR# (BV v) i | i < 0 = error $ "'shiftR undefined for negative number: " ++ show i - | otherwise = fromInteger_INLINE (shiftR v i) + | otherwise = BV (shiftR v i) {-# NOINLINE rotateL# #-} rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" @@ -532,23 +566,21 @@ b'' = sz - b' sz = fromInteger (natVal bv) -popCountBV :: (KnownNat (n+1), KnownNat (n + 2)) - => BitVector (n+1) - -> I.Index (n+2) -popCountBV bv = sum (V.map fromIntegral v) - where - v = V.bv2v bv +popCountBV :: forall n . KnownNat n => BitVector (n+1) -> I.Index (n+2) +popCountBV bv = + let v = V.bv2v bv + in sum (V.map fromIntegral v) {-# INLINE popCountBV #-} instance Resize BitVector where resize = resize# - zeroExtend = resize# - signExtend = resize# + zeroExtend = extend truncateB = resize# {-# NOINLINE resize# #-} -resize# :: KnownNat m => BitVector n -> BitVector m -resize# (BV n) = fromInteger_INLINE n +resize# :: forall n m . KnownNat m => BitVector n -> BitVector m +resize# (BV i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m)) + in if i >= m then fromInteger_INLINE i else BV i instance KnownNat n => Lift (BitVector n) where lift bv@(BV i) = sigE [| fromInteger# i |] (decBitVector (natVal bv)) @@ -557,33 +589,39 @@ decBitVector :: Integer -> TypeQ decBitVector n = appT (conT ''BitVector) (litT $ numTyLit n) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + n)) => - SaturatingNum (BitVector n) where +instance KnownNat 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 + satPlus SatZero a b = + let r = plus# a b + in case msb# r of + 0 -> resize# r + _ -> minBound# + satPlus _ a b = + let r = plus# a b + in case msb# r of + 0 -> resize# r + _ -> maxBound# satMin SatWrap a b = a -# b - satMin _ a b = case msb# r of - 0 -> resize# r - _ -> minBound# - where - r = minus# a b + satMin _ a b = + let r = minus# a b + in case msb# r of + 0 -> resize# r + _ -> minBound# 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 + satMult SatZero a b = + let r = times# a b + (rL,rR) = split# r + in case rL of + 0 -> rR + _ -> minBound# + satMult _ a b = + let r = times# a b + (rL,rR) = split# r + in case rL of + 0 -> rR + _ -> maxBound# instance KnownNat n => Arbitrary (BitVector n) where arbitrary = arbitraryBoundedIntegral diff --git a/src/CLaSH/Sized/Internal/Index.hs b/src/CLaSH/Sized/Internal/Index.hs --- a/src/CLaSH/Sized/Internal/Index.hs +++ b/src/CLaSH/Sized/Internal/Index.hs @@ -11,17 +11,21 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.Index ( -- * Datatypes Index (..) + -- * Construction + , fromSNat -- * Type classes -- ** BitConvert , pack# @@ -66,17 +70,20 @@ import Text.Read (Read (..), ReadPrec) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) -import GHC.TypeLits (KnownNat, Nat, type (+), type (-), type (*), - natVal) +import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), + type (*), type (<=), type (^), natVal) import GHC.TypeLits.Extra (CLog) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), arbitraryBoundedIntegral, coarbitraryIntegral, shrinkIntegral) -import CLaSH.Class.BitPack (BitPack (..)) -import CLaSH.Class.Num (ExtendingNum (..)) -import CLaSH.Class.Resize (Resize (..)) +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Class.Num (ExtendingNum (..), SaturatingNum (..), + SaturationMode (..)) +import CLaSH.Class.Resize (Resize (..)) import {-# SOURCE #-} CLaSH.Sized.Internal.BitVector (BitVector (BV)) +import CLaSH.Promoted.Nat (SNat, snatToNum) +import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-bounded unsigned integer represented by @ceil(log_2(n))@ bits. -- @@ -92,12 +99,15 @@ -- 3 -- >>> 2 + 6 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7] +-- ... -- >>> 1 - 3 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result -2 is out of bounds: [0..7] +-- ... -- >>> 2 * 3 :: Index 8 -- 6 -- >>> 2 * 4 :: Index 8 -- *** Exception: CLaSH.Sized.Index: result 8 is out of bounds: [0..7] +-- ... newtype Index (n :: Nat) = -- | The constructor, 'I', and the field, 'unsafeToInteger', are not -- synthesisable. @@ -115,6 +125,10 @@ pack = pack# unpack = unpack# +-- | Safely convert an `SNat` value to an `Index` +fromSNat :: (KnownNat m, CmpNat n m ~ 'LT) => SNat n -> Index m +fromSNat = snatToNum + {-# NOINLINE pack# #-} pack# :: Index n -> BitVector (CLog 2 n) pack# (I i) = BV i @@ -167,12 +181,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: Index n -> [Index n] -enumFromThen# :: Index n -> Index n -> [Index n] +enumFrom# :: KnownNat n => Index n -> [Index n] +enumFromThen# :: KnownNat n => Index n -> Index n -> [Index n] enumFromTo# :: Index n -> Index n -> [Index n] enumFromThenTo# :: Index n -> Index n -> Index n -> [Index n] -enumFrom# x = map I [unsafeToInteger x ..] -enumFromThen# x y = map I [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map I [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map I [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -209,10 +223,9 @@ fromInteger# = fromInteger_INLINE {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Index n -fromInteger_INLINE i = bound `seq` if i' == i then I i else err +fromInteger_INLINE i = bound `seq` if i > (-1) && i < bound then I i else err where - bound = natVal (Proxy :: Proxy n) - i' = i `mod` bound + bound = natVal (Proxy @n) err = error ("CLaSH.Sized.Index: result " ++ show i ++ " is out of bounds: [0.." ++ show (bound - 1) ++ "]") @@ -239,6 +252,43 @@ times# :: Index m -> Index n -> Index (((m - 1) * (n - 1)) + 1) times# (I a) (I b) = I (a * b) +instance (KnownNat n, 1 <= (n*2), (n*2) <= (n^2)) => SaturatingNum (Index n) where + satPlus SatWrap a b = case plus# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> resize# (z - m) + z -> resize# z + satPlus SatZero a b = case plus# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> fromInteger# 0 + z -> resize# z + satPlus _ a b = case plus# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> maxBound# + z -> resize# z + + satMin SatWrap a b = + if lt# a b + then maxBound -# (b -# a) +# 1 + else a -# b + + satMin _ a b = + if lt# a b + then fromInteger# 0 + else a -# b + + satMult SatWrap a b = case times# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> resize# (z - m) + z -> resize# z + satMult SatZero a b = case times# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> fromInteger# 0 + z -> resize# z + satMult _ a b = case times# a b of + z | let m = fromInteger# (natVal (Proxy @ n)) + , z >= m -> maxBound# + z -> resize# z + instance KnownNat n => Real (Index n) where toRational = toRational . toInteger# @@ -263,8 +313,7 @@ instance Resize Index where resize = resize# - zeroExtend = resize# - signExtend = resize# + zeroExtend = extend truncateB = resize# resize# :: KnownNat m => Index n -> Index m @@ -281,6 +330,9 @@ instance Show (Index n) where show (I i) = show i {-# NOINLINE show #-} + +instance ShowX (Index n) where + showsPrecX = showsPrecXWith showsPrec -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Index n) where diff --git a/src/CLaSH/Sized/Internal/Index.hs-boot b/src/CLaSH/Sized/Internal/Index.hs-boot --- a/src/CLaSH/Sized/Internal/Index.hs-boot +++ b/src/CLaSH/Sized/Internal/Index.hs-boot @@ -6,6 +6,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RoleAnnotations #-} module CLaSH.Sized.Internal.Index where @@ -15,4 +16,4 @@ data Index :: Nat -> * instance KnownNat n => Num (Index n) -instance KnownNat n => Enum (Index n) +toInteger# :: Index n -> Integer diff --git a/src/CLaSH/Sized/Internal/Signed.hs b/src/CLaSH/Sized/Internal/Signed.hs --- a/src/CLaSH/Sized/Internal/Signed.hs +++ b/src/CLaSH/Sized/Internal/Signed.hs @@ -4,21 +4,24 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} {-# OPTIONS_HADDOCK show-extensions #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} module CLaSH.Sized.Internal.Signed ( -- * Datatypes @@ -88,6 +91,7 @@ import Data.Proxy (Proxy (..)) import Text.Read (Read (..), ReadPrec) import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), @@ -100,9 +104,9 @@ 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 (BV), Bit, (++#), high, low) import qualified CLaSH.Sized.Internal.BitVector as BV +import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-width signed integer represented by @n@ bits, including the sign -- bit. @@ -143,7 +147,7 @@ -- | The constructor, 'S', and the field, 'unsafeToInteger', are not -- synthesisable. S { unsafeToInteger :: Integer} - deriving Data + deriving (Data) {-# NOINLINE size# #-} size# :: KnownNat n => Signed n -> Int @@ -159,6 +163,9 @@ show (S i) = show i {-# NOINLINE show #-} +instance ShowX (Signed n) where + showsPrecX = showsPrecXWith showsPrec + -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Signed n) where readPrec = fromIntegral <$> (readPrec :: ReadPrec Int) @@ -169,14 +176,15 @@ unpack = unpack# {-# NOINLINE pack# #-} -pack# :: KnownNat n => Signed n -> BitVector n -pack# s@(S i) = BV (i `mod` maxI) - where - maxI = 2 ^ natVal s +pack# :: forall n . KnownNat n => Signed n -> BitVector n +pack# (S i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + in if i < 0 then BV (m + i) else BV i {-# NOINLINE unpack# #-} -unpack# :: KnownNat n => BitVector n -> Signed n -unpack# (BV i) = fromInteger_INLINE i +unpack# :: forall n . KnownNat n => BitVector n -> Signed n +unpack# (BV i) = + let m = 1 `shiftL` fromInteger (natVal (Proxy @n) - 1) + in if i >= m then S (i-2*m) else S i instance Eq (Signed n) where (==) = eq# @@ -222,12 +230,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: Signed n -> [Signed n] -enumFromThen# :: Signed n -> Signed n -> [Signed n] +enumFrom# :: KnownNat n => Signed n -> [Signed n] +enumFromThen# :: KnownNat n => Signed n -> Signed n -> [Signed n] enumFromTo# :: Signed n -> Signed n -> [Signed n] enumFromThenTo# :: Signed n -> Signed n -> Signed n -> [Signed n] -enumFrom# x = map S [unsafeToInteger x ..] -enumFromThen# x y = map S [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map S [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map S [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -253,22 +261,32 @@ if s > 0 then 1 else 0 fromInteger = fromInteger# -(+#), (-#), (*#) :: KnownNat n => Signed n -> Signed n -> Signed n +(+#), (-#), (*#) :: forall n . KnownNat n => Signed n -> Signed n -> Signed n {-# NOINLINE (+#) #-} -(S a) +# (S b) = fromInteger_INLINE (a + b) +(S a) +# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) + z = a + b + in if z >= m then S (z - 2*m) else + if z < negate m then S (z + 2*m) else S z {-# NOINLINE (-#) #-} -(S a) -# (S b) = fromInteger_INLINE (a - b) +(S a) -# (S b) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) + z = a - b + in if z < negate m then S (z + 2*m) else + if z >= m then S (z - 2*m) else S z {-# NOINLINE (*#) #-} (S a) *# (S b) = fromInteger_INLINE (a * b) -negate#,abs# :: KnownNat n => Signed n -> Signed n +negate#,abs# :: forall n . KnownNat n => Signed n -> Signed n {-# NOINLINE negate# #-} -negate# (S n) = fromInteger_INLINE (negate n) +negate# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) + z = negate n + in if z == m then S n else S z {-# NOINLINE abs# #-} -abs# (S n) = fromInteger_INLINE (abs n) +abs# (S n) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) + z = abs n + in if z == m then S n else S z {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> Signed (n :: Nat) @@ -276,33 +294,30 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Signed n -fromInteger_INLINE i = sz `seq` if sz == 0 then S 0 else S res +fromInteger_INLINE i = mask `seq` S res where - sz = natVal (Proxy :: Proxy n) - mask = shiftL 1 (fromInteger sz - 1) + mask = 1 `shiftL` fromInteger (natVal (Proxy @n) -1) res = case divMod i mask of (s,i') | even s -> i' | otherwise -> i' - mask -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) +instance ExtendingNum (Signed m) (Signed n) where + type AResult (Signed m) (Signed n) = Signed (Max m n + 1) 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) +plus#, minus# :: Signed m -> Signed n -> Signed (Max m n + 1) {-# NOINLINE plus# #-} -plus# (S a) (S b) = fromInteger_INLINE (a + b) +plus# (S a) (S b) = S (a + b) {-# NOINLINE minus# #-} -minus# (S a) (S b) = fromInteger_INLINE (a - b) +minus# (S a) (S b) = S (a - b) {-# NOINLINE times# #-} -times# :: KnownNat (m + n) => Signed m -> Signed n -> Signed (m + n) -times# (S a) (S b) = fromInteger_INLINE (a * b) +times# :: Signed m -> Signed n -> Signed (m + n) +times# (S a) (S b) = S (a * b) instance KnownNat n => Real (Signed n) where toRational = toRational . toInteger# @@ -332,7 +347,7 @@ toInteger# :: Signed n -> Integer toInteger# (S n) = n -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => Bits (Signed n) where +instance KnownNat n => Bits (Signed n) where (.&.) = and# (.|.) = or# xor = xor# @@ -395,32 +410,31 @@ b'' = sz - b' sz = fromInteger (natVal s) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => FiniteBits (Signed n) where - finiteBitSize = size# +instance KnownNat n => FiniteBits (Signed n) where + finiteBitSize = size# + countLeadingZeros s = countLeadingZeros (pack# s) + countTrailingZeros s = countTrailingZeros (pack# s) 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 +resize# :: forall m n . (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 + n = fromInteger (natVal s) + n' = shiftL 1 n + m' = shiftL mask 1 + extended = S 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' + mask = 1 `shiftL` fromInteger (natVal (Proxy @m) -1) + i' = i `mod` mask + truncated = if testBit i (n-1) + then S (i' - mask) + else S i' {-# NOINLINE truncateB# #-} truncateB# :: KnownNat m => Signed (m + n) -> Signed m @@ -436,55 +450,84 @@ 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 +instance KnownNat n => SaturatingNum (Signed n) where + satPlus SatWrap a b = a +# b + satPlus SatBound a b = + let r = plus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a .&. msb b of + 0 -> maxBound# + _ -> minBound# + satPlus SatZero a b = + let r = plus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> fromInteger# 0 + satPlus SatSymmetric a b = + let r = plus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a .&. msb b of + 0 -> maxBound# + _ -> minBoundSym# 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 - + satMin SatBound a b = + let r = minus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a ++# msb b of + 2 -> minBound# + _ -> maxBound# + satMin SatZero a b = + let r = minus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> fromInteger# 0 + satMin SatSymmetric a b = + let r = minus# a b + (_,r') = split r + in case msb r `xor` msb r' of + 0 -> unpack# r' + _ -> case msb a ++# msb b of + 2 -> minBoundSym# + _ -> maxBound# 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 + satMult SatBound a b = + let r = times# a b + (rL,rR) = split r + overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack# rR + _ -> case msb rL of + 0 -> maxBound# + _ -> minBound# + satMult SatZero a b = + let r = times# a b + (rL,rR) = split r + overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack# rR + _ -> fromInteger# 0 + satMult SatSymmetric a b = + let r = times# a b + (rL,rR) = split r + overflow = complement (reduceOr (msb rR ++# pack rL)) .|. + reduceAnd (msb rR ++# pack rL) + in case overflow of + 1 -> unpack# rR + _ -> case msb rL of + 0 -> maxBound# + _ -> minBoundSym# 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 --- a/src/CLaSH/Sized/Internal/Unsigned.hs +++ b/src/CLaSH/Sized/Internal/Unsigned.hs @@ -6,17 +6,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Unsafe #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Internal.Unsigned @@ -81,6 +82,7 @@ import Data.Proxy (Proxy (..)) import Text.Read (Read (..), ReadPrec) import GHC.TypeLits (KnownNat, Nat, type (+), natVal) +import GHC.TypeLits.Extra (Max) import Language.Haskell.TH (TypeQ, appT, conT, litT, numTyLit, sigE) import Language.Haskell.TH.Syntax (Lift(..)) import Test.QuickCheck.Arbitrary (Arbitrary (..), CoArbitrary (..), @@ -93,9 +95,9 @@ 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 (BV), Bit, high, low) import qualified CLaSH.Sized.Internal.BitVector as BV +import CLaSH.XException (ShowX (..), showsPrecXWith) -- | Arbitrary-width unsigned integer represented by @n@ bits -- @@ -148,6 +150,9 @@ show (U i) = show i {-# NOINLINE show #-} +instance ShowX (Unsigned n) where + showsPrecX = showsPrecXWith showsPrec + -- | None of the 'Read' class' methods are synthesisable. instance KnownNat n => Read (Unsigned n) where readPrec = fromIntegral <$> (readPrec :: ReadPrec Word) @@ -209,12 +214,12 @@ {-# NOINLINE enumFromThen# #-} {-# NOINLINE enumFromTo# #-} {-# NOINLINE enumFromThenTo# #-} -enumFrom# :: Unsigned n -> [Unsigned n] -enumFromThen# :: Unsigned n -> Unsigned n -> [Unsigned n] +enumFrom# :: KnownNat n => Unsigned n -> [Unsigned n] +enumFromThen# :: KnownNat n => Unsigned n -> Unsigned n -> [Unsigned n] enumFromTo# :: Unsigned n -> Unsigned n -> [Unsigned n] enumFromThenTo# :: Unsigned n -> Unsigned n -> Unsigned n -> [Unsigned n] -enumFrom# x = map U [unsafeToInteger x ..] -enumFromThen# x y = map U [unsafeToInteger x, unsafeToInteger y ..] +enumFrom# x = map fromInteger_INLINE [unsafeToInteger x ..] +enumFromThen# x y = map fromInteger_INLINE [unsafeToInteger x, unsafeToInteger y ..] enumFromTo# x y = map U [unsafeToInteger x .. unsafeToInteger y] enumFromThenTo# x1 x2 y = map U [unsafeToInteger x1, unsafeToInteger x2 .. unsafeToInteger y] @@ -227,8 +232,9 @@ minBound# = U 0 {-# NOINLINE maxBound# #-} -maxBound# :: KnownNat n => Unsigned n -maxBound# = let res = U ((2 ^ natVal res) - 1) in res +maxBound# :: forall n .KnownNat n => Unsigned n +maxBound# = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + in U (m - 1) instance KnownNat n => Num (Unsigned n) where (+) = (+#) @@ -239,21 +245,26 @@ signum bv = resize# (unpack# (reduceOr bv)) fromInteger = fromInteger# -(+#),(-#),(*#) :: KnownNat n => Unsigned n -> Unsigned n -> Unsigned n +(+#),(-#),(*#) :: forall n . KnownNat n => Unsigned n -> Unsigned n -> Unsigned n {-# NOINLINE (+#) #-} -(+#) (U i) (U j) = fromInteger_INLINE (i + j) +(+#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + z = i + j + in if z >= m then U (z - m) else U z {-# NOINLINE (-#) #-} -(-#) (U i) (U j) = fromInteger_INLINE (i - j) +(-#) (U i) (U j) = let m = 1 `shiftL` fromInteger (natVal (Proxy @n)) + z = i - j + in if z < 0 then U (m + z) else U z {-# NOINLINE (*#) #-} (*#) (U i) (U j) = fromInteger_INLINE (i * j) {-# NOINLINE negate# #-} -negate# :: KnownNat n => Unsigned n -> Unsigned n -negate# u@(U i) = sz `seq` U (sz - i) +negate# :: forall n . KnownNat n => Unsigned n -> Unsigned n +negate# (U 0) = U 0 +negate# (U i) = sz `seq` U (sz - i) where - sz = 2 ^ natVal u + sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) {-# NOINLINE fromInteger# #-} fromInteger# :: KnownNat n => Integer -> Unsigned n @@ -261,29 +272,33 @@ {-# INLINE fromInteger_INLINE #-} fromInteger_INLINE :: forall n . KnownNat n => Integer -> Unsigned n -fromInteger_INLINE i = sz `seq` U (i `mod` (shiftL 1 sz)) +fromInteger_INLINE i = U (i `mod` sz) where - sz = fromInteger (natVal (Proxy :: Proxy n)) + sz = 1 `shiftL` fromInteger (natVal (Proxy @n)) -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) +instance (KnownNat m, KnownNat n) => ExtendingNum (Unsigned m) (Unsigned n) where + type AResult (Unsigned m) (Unsigned n) = Unsigned (Max m n + 1) 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) +plus# :: Unsigned m -> Unsigned n -> Unsigned (Max m n + 1) +plus# (U a) (U b) = U (a + b) {-# NOINLINE minus# #-} -minus# (U a) (U b) = fromInteger_INLINE (a - b) +minus# :: forall m n . (KnownNat m, KnownNat n) => Unsigned m -> Unsigned n + -> Unsigned (Max m n + 1) +minus# (U a) (U b) = + let sz = fromInteger (natVal (Proxy @(Max m n + 1))) + mask = 1 `shiftL` sz + z = a - b + in if z < 0 then U (mask + z) else U z {-# NOINLINE times# #-} -times# :: KnownNat (m + n) => Unsigned m -> Unsigned n -> Unsigned (m + n) -times# (U a) (U b) = fromInteger_INLINE (a * b) +times# :: Unsigned m -> Unsigned n -> Unsigned (m + n) +times# (U a) (U b) = U (a * b) instance KnownNat n => Real (Unsigned n) where toRational = toRational . toInteger# @@ -307,7 +322,7 @@ toInteger# :: Unsigned n -> Integer toInteger# (U i) = i -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => Bits (Unsigned n) where +instance KnownNat n => Bits (Unsigned n) where (.&.) = and# (.|.) = or# xor = xor# @@ -343,8 +358,7 @@ 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 +shiftL#, rotateL#, rotateR# :: KnownNat n => Unsigned n -> Int -> Unsigned n {-# NOINLINE shiftL# #-} shiftL# (U v) i | i < 0 = error @@ -352,10 +366,11 @@ | otherwise = fromInteger_INLINE (shiftL v i) {-# NOINLINE shiftR# #-} +shiftR# :: Unsigned n -> Int -> Unsigned n shiftR# (U v) i | i < 0 = error $ "'shiftR undefined for negative number: " ++ show i - | otherwise = fromInteger_INLINE (shiftR v i) + | otherwise = U (shiftR v i) {-# NOINLINE rotateL# #-} rotateL# _ b | b < 0 = error "'shiftL undefined for negative numbers" @@ -379,18 +394,20 @@ b'' = sz - b' sz = fromInteger (natVal bv) -instance (KnownNat n, KnownNat (n + 1), KnownNat (n + 2)) => FiniteBits (Unsigned n) where - finiteBitSize = size# +instance KnownNat n => FiniteBits (Unsigned n) where + finiteBitSize = size# + countLeadingZeros u = countLeadingZeros (pack# u) + countTrailingZeros u = countTrailingZeros (pack# u) instance Resize Unsigned where resize = resize# - zeroExtend = resize# - signExtend = resize# + zeroExtend = extend truncateB = resize# {-# NOINLINE resize# #-} -resize# :: KnownNat m => Unsigned n -> Unsigned m -resize# (U i) = fromInteger_INLINE i +resize# :: forall n m . KnownNat m => Unsigned n -> Unsigned m +resize# (U i) = let m = 1 `shiftL` fromInteger (natVal (Proxy @m)) + in if i >= m then fromInteger_INLINE i else U i instance Default (Unsigned n) where def = minBound# @@ -402,33 +419,39 @@ decUnsigned :: Integer -> TypeQ decUnsigned n = appT (conT ''Unsigned) (litT $ numTyLit n) -instance (KnownNat n, KnownNat (1 + n), KnownNat (n + n)) => - SaturatingNum (Unsigned n) where +instance KnownNat 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 + satPlus SatZero a b = + let r = plus# a b + in case msb r of + 0 -> resize# r + _ -> minBound# + satPlus _ a b = + let r = plus# a b + in case msb r of + 0 -> resize# r + _ -> maxBound# satMin SatWrap a b = a -# b - satMin _ a b = case msb r of - 0 -> resize# r - _ -> minBound# - where - r = minus# a b + satMin _ a b = + let r = minus# a b + in case msb r of + 0 -> resize# r + _ -> minBound# 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 + satMult SatZero a b = + let r = times# a b + (rL,rR) = split r + in case rL of + 0 -> unpack# rR + _ -> minBound# + satMult _ a b = + let r = times# a b + (rL,rR) = split r + in case rL of + 0 -> unpack# rR + _ -> maxBound# instance KnownNat n => Arbitrary (Unsigned n) where arbitrary = arbitraryBoundedIntegral diff --git a/src/CLaSH/Sized/RTree.hs b/src/CLaSH/Sized/RTree.hs --- a/src/CLaSH/Sized/RTree.hs +++ b/src/CLaSH/Sized/RTree.hs @@ -4,35 +4,475 @@ Maintainer : Christiaan Baaij -} -{-# LANGUAGE DataKinds, TypeOperators, GADTs, ScopedTypeVariables, - KindSignatures, RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} -module CLaSH.Sized.RTree where +module CLaSH.Sized.RTree + ( -- * 'RTree' data type + RTree (LR, BR) + -- * Construction + , treplicate + , trepeat + -- * Accessors + -- ** Indexing + , indexTree + , tindices + -- * Modifying trees + , replaceTree + -- * Element-wise operations + -- ** Mapping + , tmap + , tzipWith + -- ** Zipping + , tzip + -- ** Unzipping + , tunzip + -- * Folding + , tfold + -- ** Specialised folds + , tdfold + -- * Conversions + , v2t + , t2v + -- * Misc + , lazyT + ) +where -import Data.Singletons.Prelude (TyFun,type ($)) +import Control.Applicative (liftA2) +import qualified Control.Lens as Lens +import Data.Default (Default (..)) +import Data.Foldable (toList) +import Data.Singletons.Prelude (Apply, TyFun, type (@@)) import Data.Proxy (Proxy (..)) -import GHC.TypeLits (KnownNat, Nat, type (+)) +import GHC.TypeLits (KnownNat, Nat, type (+), type (^), type (*)) +import Language.Haskell.TH.Syntax (Lift(..)) +import qualified Prelude as P +import Prelude hiding ((++), (!!)) +import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) -import CLaSH.Promoted.Nat (SNat, snat, subSNat) +import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatToNum, + subSNat, toUNat) import CLaSH.Promoted.Nat.Literals (d1) +import CLaSH.Sized.Index (Index) +import CLaSH.Sized.Vector (Vec (..), (!!), (++), dtfold, replace) +import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) +{- $setup +>>> :set -XDataKinds +>>> :set -XTypeFamilies +>>> :set -XTypeOperators +>>> :set -XTemplateHaskell +>>> :set -XFlexibleContexts +>>> :set -XTypeApplications +>>> :set -fplugin GHC.TypeLits.Normalise +>>> :set -XUndecidableInstances +>>> import CLaSH.Prelude +>>> data IIndex (f :: TyFun Nat *) :: * +>>> type instance Apply IIndex l = Index ((2^l)+1) +>>> :{ +let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1) + populationCount' bv = tdfold (Proxy @IIndex) + fromIntegral + (\_ x y -> plus x y) + (v2t (bv2v bv)) +:} +-} + +-- | Perfect depth binary tree. +-- +-- * Only has elements at the leaf of the tree +-- * A tree of depth /d/ has /2^d/ elements. data RTree :: Nat -> * -> * where - LR :: a -> RTree 0 a - BR :: RTree n a -> RTree n a -> RTree (n+1) a + LR_ :: a -> RTree 0 a + BR_ :: RTree d a -> RTree d a -> RTree (d+1) a -tfold :: forall p k a . KnownNat k - => Proxy (p :: TyFun Nat * -> *) - -> (a -> (p $ 0)) - -> (forall l . SNat l -> (p $ l) -> (p $ l) -> (p $ (l+1))) - -> RTree k a - -> (p $ k) -tfold _ f g = go snat +textract :: RTree 0 a -> a +textract (LR_ x) = x +{-# NOINLINE textract #-} + +tsplit :: RTree (d+1) a -> (RTree d a,RTree d a) +tsplit (BR_ l r) = (l,r) +{-# NOINLINE tsplit #-} + +-- | Leaf of a perfect depth tree +-- +-- >>> LR 1 +-- 1 +-- >>> let x = LR 1 +-- >>> :t x +-- x :: Num a => RTree 0 a +-- +-- Can be used as a pattern: +-- +-- >>> let f (LR a) (LR b) = a + b +-- >>> :t f +-- f :: Num a => RTree 0 a -> RTree 0 a -> a +-- >>> f (LR 1) (LR 2) +-- 3 +pattern LR :: a -> RTree 0 a +pattern LR x <- (textract -> x) where - go :: SNat m -> RTree m a -> (p $ m) - go _ (LR a) = f a - go sn (BR l r) = let sn' = sn `subSNat` d1 - in g sn' (go sn' l) (go sn' r) + LR x = LR_ x + +-- | Branch of a perfect depth tree +-- +-- >>> BR (LR 1) (LR 2) +-- <1,2> +-- >>> let x = BR (LR 1) (LR 2) +-- >>> :t x +-- x :: Num a => RTree 1 a +-- +-- Case be used a pattern: +-- +-- >>> let f (BR (LR a) (LR b)) = LR (a + b) +-- >>> :t f +-- f :: Num a => RTree 1 a -> RTree 0 a +-- >>> f (BR (LR 1) (LR 2)) +-- 3 +pattern BR :: RTree d a -> RTree d a -> RTree (d+1) a +pattern BR l r <- ((\t -> (tsplit t)) -> (l,r)) + where + BR l r = BR_ l r + +instance (KnownNat d, Eq a) => Eq (RTree d a) where + (==) t1 t2 = (==) (t2v t1) (t2v t2) + +instance (KnownNat d, Ord a) => Ord (RTree d a) where + compare t1 t2 = compare (t2v t1) (t2v t2) + +instance Show a => Show (RTree n a) where + showsPrec _ (LR_ a) = shows a + showsPrec _ (BR_ l r) = \s -> '<':shows l (',':shows r ('>':s)) + +instance ShowX a => ShowX (RTree n a) where + showsPrecX = showsPrecXWith go + where + go :: Int -> RTree d a -> ShowS + go _ (LR_ a) = showsX a + go _ (BR_ l r) = \s -> '<':showsX l (',':showsX r ('>':s)) + +instance KnownNat d => Functor (RTree d) where + fmap = tmap + +instance KnownNat d => Applicative (RTree d) where + pure = trepeat + (<*>) = tzipWith ($) + +instance KnownNat d => Foldable (RTree d) where + foldMap f = tfold f mappend + +data TraversableTree (g :: * -> *) (a :: *) (f :: TyFun Nat *) :: * +type instance Apply (TraversableTree f a) d = f (RTree d a) + +instance KnownNat d => Traversable (RTree d) where + traverse :: forall f a b . Applicative f => (a -> f b) -> RTree d a -> f (RTree d b) + traverse f = tdfold (Proxy @(TraversableTree f b)) + (fmap LR . f) + (const (liftA2 BR)) + +instance (KnownNat d, KnownNat (BitSize a), BitPack a) => + BitPack (RTree d a) where + type BitSize (RTree d a) = (2^d) * (BitSize a) + pack = pack . t2v + unpack = v2t . unpack + +type instance Lens.Index (RTree d a) = Int +type instance Lens.IxValue (RTree d a) = a +instance KnownNat d => Lens.Ixed (RTree d a) where + ix i f t = replaceTree i <$> f (indexTree t i) <*> pure t + +instance (KnownNat d, Default a) => Default (RTree d a) where + def = trepeat def + +instance Lift a => Lift (RTree d a) where + lift (LR_ a) = [| LR_ a |] + lift (BR_ t1 t2) = [| BR_ $(lift t1) $(lift t2) |] + +instance (KnownNat d, Arbitrary a) => Arbitrary (RTree d a) where + arbitrary = sequenceA (trepeat arbitrary) + shrink = sequenceA . fmap shrink + +instance (KnownNat d, CoArbitrary a) => CoArbitrary (RTree d a) where + coarbitrary = coarbitrary . toList + +-- | A /dependently/ typed fold over trees. +-- +-- As an example of when you might want to use 'dtfold' we will build a +-- population counter: a circuit that counts the number of bits set to '1' in +-- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type +-- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range +-- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@. +-- As an initial attempt we will use 'tfold', because it gives a nice (@log2(n)@) +-- tree-structure of adders: +-- +-- @ +-- populationCount :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) +-- => BitVector (2^d) -> Index (2^d+1) +-- populationCount = tfold fromIntegral (+) . v2t . bv2v +-- @ +-- +-- The \"problem\" with this description is that all adders have the same +-- bit-width, i.e. all adders are of the type: +-- +-- @ +-- (+) :: 'Index' (2^d+1) -> 'Index' (2^d+1) -> 'Index' (2^d+1). +-- @ +-- +-- This is a \"problem\" because we could have a more efficient structure: +-- one where each layer of adders is /precisely/ wide enough to count the number +-- of bits at that layer. That is, at height /d/ we want the adder to be of +-- type: +-- +-- @ +-- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1) +-- @ +-- +-- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as +-- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'. +-- However, we cannot simply use 'fold' to create a tree-structure of +-- 'CLaSH.Class.Num.plus'es: +-- +-- >>> :{ +-- let populationCount' :: (KnownNat (2^d), KnownNat d, KnownNat (2^d+1)) +-- => BitVector (2^d) -> Index (2^d+1) +-- populationCount' = tfold fromIntegral plus . v2t . bv2v +-- :} +-- +-- :... +-- • Couldn't match type ‘(((2 ^ d) + 1) + ((2 ^ d) + 1)) - 1’ +-- with ‘(2 ^ d) + 1’ +-- Expected type: Index ((2 ^ d) + 1) +-- -> Index ((2 ^ d) + 1) -> Index ((2 ^ d) + 1) +-- Actual type: Index ((2 ^ d) + 1) +-- -> Index ((2 ^ d) + 1) +-- -> AResult (Index ((2 ^ d) + 1)) (Index ((2 ^ d) + 1)) +-- • In the second argument of ‘tfold’, namely ‘plus’ +-- In the first argument of ‘(.)’, namely ‘tfold fromIntegral plus’ +-- In the expression: tfold fromIntegral plus . v2t . bv2v +-- • Relevant bindings include +-- populationCount' :: BitVector (2 ^ d) -> Index ((2 ^ d) + 1) +-- (bound at ...) +-- +-- because 'tfold' expects a function of type \"@b -> b -> b@\", i.e. a function +-- where the arguments and result all have exactly the same type. +-- +-- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the +-- result is larger than the arguments, we must use a dependently typed fold in +-- the the form of 'dtfold': +-- +-- @ +-- {\-\# LANGUAGE UndecidableInstances \#-\} +-- import Data.Singletons.Prelude +-- import Data.Proxy +-- +-- data IIndex (f :: 'TyFun' Nat *) :: * +-- type instance 'Apply' IIndex l = 'Index' ((2^l)+1) +-- +-- populationCount' :: (KnownNat k, KnownNat (2^k)) +-- => BitVector (2^k) -> Index ((2^k)+1) +-- populationCount' bv = 'tdfold' (Proxy @IIndex) +-- fromIntegral +-- (\\_ x y -> 'CLaSH.Class.Num.plus' x y) +-- ('v2t' ('CLaSH.Sized.Vector.bv2v' bv)) +-- @ +-- +-- And we can test that it works: +-- +-- >>> :t populationCount' (7 :: BitVector 16) +-- populationCount' (7 :: BitVector 16) :: Index 17 +-- >>> populationCount' (7 :: BitVector 16) +-- 3 +tdfold :: forall p k a . KnownNat k + => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ + -> (a -> (p @@ 0)) -- ^ Function to apply to the elements on the leafs + -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l+1))) + -- ^ Function to fold the branches with. + -- + -- __NB:__ @SNat l@ is the depth of the two sub-branches. + -> RTree k a -- ^ Tree to fold over. + -> (p @@ k) +tdfold _ f g = go SNat + where + go :: SNat m -> RTree m a -> (p @@ m) + go _ (LR_ a) = f a + go sn (BR_ l r) = let sn' = sn `subSNat` d1 + in g sn' (go sn' l) (go sn' r) +{-# NOINLINE tdfold #-} + +data TfoldTree (a :: *) (f :: TyFun Nat *) :: * +type instance Apply (TfoldTree a) d = a + +-- | Reduce a tree to a single element +tfold :: forall d a b . + KnownNat d + => (a -> b) -- ^ Function to apply to the leaves + -> (b -> b -> b) -- ^ Function to combine the results of the reduction + -- of two branches + -> RTree d a -- ^ Tree to fold reduce + -> b +tfold f g = tdfold (Proxy @(TfoldTree b)) f (const g) + +-- | \"'treplicate' @d a@\" returns a tree of depth /d/, and has /2^d/ copies +-- of /a/. +-- +-- >>> treplicate (SNat :: SNat 3) 6 +-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>> +-- >>> treplicate d3 6 +-- <<<6,6>,<6,6>>,<<6,6>,<6,6>>> +treplicate :: forall d a . SNat d -> a -> RTree d a +treplicate sn a = go (toUNat sn) + where + go :: UNat n -> RTree n a + go UZero = LR a + go (USucc un) = BR (go un) (go un) +{-# NOINLINE treplicate #-} + +-- | \"'trepeat' @a@\" creates a tree with as many copies of /a/ as demanded by +-- the context. +-- +-- >>> trepeat 6 :: RTree 2 Int +-- <<6,6>,<6,6>> +trepeat :: KnownNat d => a -> RTree d a +trepeat = treplicate SNat + +data MapTree (a :: *) (f :: TyFun Nat *) :: * +type instance Apply (MapTree a) d = RTree d a + +-- | \"'tmap' @f t@\" is the tree obtained by apply /f/ to each element of /t/, +-- i.e., +-- +-- > tmap f (BR (LR a) (LR b)) == BR (LR (f a)) (LR (f b)) +tmap :: forall d a b . KnownNat d => (a -> b) -> RTree d a -> RTree d b +tmap f = tdfold (Proxy @(MapTree b)) (LR . f) (\_ l r -> BR l r) + +-- | Generate a tree of indices, where the depth of the tree is determined by +-- the context. +-- +-- >>> tindices :: RTree 3 (Index 8) +-- <<<0,1>,<2,3>>,<<4,5>,<6,7>>> +tindices :: forall d . KnownNat d => RTree d (Index (2^d)) +tindices = + tdfold (Proxy @(MapTree (Index (2^d)))) LR + (\s@SNat l r -> BR l (tmap (+(snatToNum (pow2SNat s))) r)) + (treplicate SNat 0) + +data V2TTree (a :: *) (f :: TyFun Nat *) :: * +type instance Apply (V2TTree a) d = RTree d a + +-- | Convert a vector with /2^d/ elements to a tree of depth /d/. +-- +-- >>> (1:>2:>3:>4:>Nil) +-- <1,2,3,4> +-- >>> v2t (1:>2:>3:>4:>Nil) +-- <<1,2>,<3,4>> +v2t :: forall d a . KnownNat d => Vec (2^d) a -> RTree d a +v2t = dtfold (Proxy @(V2TTree a)) LR (const BR) + +data T2VTree (a :: *) (f :: TyFun Nat *) :: * +type instance Apply (T2VTree a) d = Vec (2^d) a + +-- | Convert a tree of depth /d/ to a vector of /2^d/ elements +-- +-- >>> (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) +-- <<1,2>,<3,4>> +-- >>> t2v (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) +-- <1,2,3,4> +t2v :: forall d a . KnownNat d => RTree d a -> Vec (2^d) a +t2v = tdfold (Proxy @(T2VTree a)) (:> Nil) (\_ l r -> l ++ r) + +-- | \"'indexTree' @t n@\" returns the /n/'th element of /t/. +-- +-- The bottom-left leaf had index /0/, and the bottom-right leaf has index +-- /2^d-1/, where /d/ is the depth of the tree +-- +-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 0 +-- 1 +-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 2 +-- 3 +-- >>> indexTree (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) 14 +-- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 3 +-- ... +indexTree :: (KnownNat d, Enum i) => RTree d a -> i -> a +indexTree t i = (t2v t) !! i + +-- | \"'replaceTree' @n a t@\" returns the tree /t/ where the /n/'th element is +-- replaced by /a/. +-- +-- The bottom-left leaf had index /0/, and the bottom-right leaf has index +-- /2^d-1/, where /d/ is the depth of the tree +-- +-- >>> replaceTree 0 5 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) +-- <<5,2>,<3,4>> +-- >>> replaceTree 2 7 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) +-- <<1,2>,<7,4>> +-- >>> replaceTree 9 6 (BR (BR (LR 1) (LR 2)) (BR (LR 3) (LR 4))) +-- <<1,2>,<3,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 3 +-- ... +replaceTree :: (KnownNat d, Enum i) => i -> a -> RTree d a -> RTree d a +replaceTree i a = v2t . replace i a . t2v + +data ZipWithTree (b :: *) (c :: *) (f :: TyFun Nat *) :: * +type instance Apply (ZipWithTree b c) d = RTree d b -> RTree d c + +-- | 'tzipWith' generalises 'tzip' by zipping with the function given as the +-- first argument, instead of a tupling function. For example, "tzipWith (+)" +-- applied to two trees produces the tree of corresponding sums. +-- +-- > tzipWith f (BR (LR a1) (LR b1)) (BR (LR a2) (LR b2)) == BR (LR (f a1 a2)) (LR (f b1 b2)) +tzipWith :: forall a b c d . KnownNat d => (a -> b -> c) -> RTree d a -> RTree d b -> RTree d c +tzipWith f = tdfold (Proxy @(ZipWithTree b c)) lr br + where + lr :: a -> RTree 0 b -> RTree 0 c + lr a (LR b) = LR (f a b) + lr _ _ = error "impossible" + + br :: SNat l + -> (RTree l b -> RTree l c) + -> (RTree l b -> RTree l c) + -> RTree (l+1) b + -> RTree (l+1) c + br _ fl fr (BR l r) = BR (fl l) (fr r) + br _ _ _ _ = error "impossible" + +-- | 'tzip' takes two trees and returns a tree of corresponding pairs. +tzip :: KnownNat d => RTree d a -> RTree d b -> RTree d (a,b) +tzip = tzipWith (,) + +data UnzipTree (a :: *) (b :: *) (f :: TyFun Nat *) :: * +type instance Apply (UnzipTree a b) d = (RTree d a, RTree d b) + +-- | 'tunzip' transforms a tree of pairs into a tree of first components and a +-- tree of second components. +tunzip :: forall d a b . KnownNat d => RTree d (a,b) -> (RTree d a,RTree d b) +tunzip = tdfold (Proxy @(UnzipTree a b)) lr br + where + lr (a,b) = (LR a,LR b) + + br _ (l1,r1) (l2,r2) = (BR l1 l2, BR r1 r2) + +-- | Given a function 'f' that is strict in its /n/th 'RTree' argument, make it +-- lazy by applying 'lazyT' to this argument: +-- +-- > f x0 x1 .. (lazyT xn) .. xn_plus_k +lazyT :: KnownNat d + => RTree d a + -> RTree d a +lazyT = tzipWith (flip const) (trepeat undefined) 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 @@ -6,7 +6,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} @@ -15,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -22,13 +22,14 @@ {-# LANGUAGE Trustworthy #-} -{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-redundant-constraints #-} + {-# OPTIONS_HADDOCK show-extensions #-} module CLaSH.Sized.Vector ( -- * 'Vec'tor data type - Vec(..) + Vec(Nil,(:>),(:<)) -- * Accessors -- ** Length information , length, maxIndex, lengthS @@ -49,9 +50,8 @@ , replicate, replicateI, repeat , iterate, iterateI, generate, generateI -- *** Initialisation from a list - , v + , listToVecTH, v -- ** Concatenation - , pattern (:>), pattern (:<) , (++), (+>>), (<<+), concat , shiftInAt0, shiftInAtN , shiftOutFrom0, shiftOutFromN , merge @@ -75,7 +75,7 @@ , foldr, foldl, foldr1, foldl1, fold , ifoldr, ifoldl -- ** Specialised folds - , dfold, vfold + , dfold, dtfold, vfold -- * Prefix sums (scans) , scanl, scanr, postscanl, postscanr , mapAccumL, mapAccumR @@ -98,13 +98,13 @@ where import Control.DeepSeq (NFData (..)) -import qualified Control.Lens as Lens +import qualified Control.Lens as Lens hiding (pattern (:>), pattern (:<)) import Data.Default (Default (..)) import qualified Data.Foldable as F import Data.Proxy (Proxy (..)) -import Data.Singletons.Prelude (TyFun,Apply,type ($)) -import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (*), - type (-), natVal) +import Data.Singletons.Prelude (TyFun,Apply,type (@@)) +import GHC.TypeLits (CmpNat, KnownNat, Nat, type (+), type (-), type (*), + type (^), natVal) import GHC.Base (Int(I#),Int#,isTrue#) import GHC.Prim ((==#),(<#),(-#)) import Language.Haskell.TH (ExpQ) @@ -119,14 +119,14 @@ import Test.QuickCheck (Arbitrary (..), CoArbitrary (..)) import Unsafe.Coerce (unsafeCoerce) -import CLaSH.Promoted.Nat (SNat (..), UNat (..), snat, snatToInteger, - subSNat, withSNat, toUNat) +import CLaSH.Promoted.Nat (SNat (..), UNat (..), pow2SNat, snatProxy, + snatToInteger, subSNat, withSNat, toUNat) import CLaSH.Promoted.Nat.Literals (d1) -import CLaSH.Promoted.Nat.Unsafe (unsafeSNat) import CLaSH.Sized.Internal.BitVector (Bit, BitVector, (++#), split#) import CLaSH.Sized.Index (Index) import CLaSH.Class.BitPack (BitPack (..)) +import CLaSH.XException (ShowX (..), showsX, showsPrecXWith) {- $setup >>> :set -XDataKinds @@ -134,6 +134,7 @@ >>> :set -XTypeOperators >>> :set -XTemplateHaskell >>> :set -XFlexibleContexts +>>> :set -XTypeApplications >>> :set -fplugin GHC.TypeLits.Normalise >>> import CLaSH.Prelude >>> let compareSwapL a b = if a < b then (a,b) else (b,a) @@ -161,13 +162,23 @@ sorted = zipWith (flip compareSwapL) rights lefts :} ->>> import Data.Singletons.Prelude >>> data Append (m :: Nat) (a :: *) (f :: TyFun Nat *) :: * >>> type instance Apply (Append m a) l = Vec (l + m) a >>> let append' xs ys = dfold (Proxy :: Proxy (Append m a)) (const (:>)) ys xs >>> let compareSwap a b = if a > b then (a,b) else (b,a) >>> let insert y xs = let (y',xs') = mapAccumL compareSwap y xs in xs' :< y' ->>> let insertionSort = vfold insert +>>> let insertionSort = vfold (const insert) +>>> data IIndex (f :: TyFun Nat *) :: * +>>> :set -XUndecidableInstances +>>> type instance Apply IIndex l = Index ((2^l)+1) +>>> :{ +let populationCount' :: (KnownNat k, KnownNat (2^k)) => BitVector (2^k) -> Index ((2^k)+1) + populationCount' bv = dtfold (Proxy @IIndex) + fromIntegral + (\_ x y -> plus x y) + (bv2v bv) +:} + -} infixr 5 `Cons` @@ -175,11 +186,10 @@ -- -- * Lists with their length encoded in their type -- * 'Vec'tor elements have an __ASCENDING__ subscript starting from 0 and --- ending at 'maxIndex' (== 'length' - 1). +-- ending at @'length' - 1@. data Vec :: Nat -> * -> * where Nil :: Vec 0 a Cons :: a -> Vec n a -> Vec (n + 1) a -{-# WARNING Cons "Use ':>' instead of 'Cons'" #-} instance NFData a => NFData (Vec n a) where rnf Nil = () @@ -216,13 +226,23 @@ infixr 5 :> instance Show a => Show (Vec n a) where - show vs = "<" P.++ punc vs P.++ ">" + showsPrec _ vs = \s -> '<':punc vs ('>':s) where - punc :: Vec m a -> String - punc Nil = "" - punc (x `Cons` Nil) = show x - punc (x `Cons` xs) = show x P.++ "," P.++ punc xs + punc :: Vec m a -> ShowS + punc Nil = id + punc (x `Cons` Nil) = shows x + punc (x `Cons` xs) = \s -> shows x (',':punc xs s) +instance ShowX a => ShowX (Vec n a) where + showsPrecX = showsPrecXWith go + where + go _ vs = \s -> '<': punc vs ('>':s) + where + punc :: Vec m a -> ShowS + punc Nil = id + punc (x `Cons` Nil) = showsX x + punc (x `Cons` xs) = \s -> showsX x (',':punc xs s) + instance (KnownNat n, Eq a) => Eq (Vec n a) where (==) v1 v2 | length v1 == 0 = True @@ -268,7 +288,7 @@ traverse = traverse# {-# NOINLINE traverse# #-} -traverse# :: Applicative f => (a -> f b) -> Vec n a -> f (Vec n b) +traverse# :: forall a f b n . Applicative f => (a -> f b) -> Vec n a -> f (Vec n b) traverse# _ Nil = pure Nil traverse# f (x `Cons` xs) = Cons <$> f x <*> traverse# f xs @@ -291,11 +311,12 @@ -- >>> head Nil -- -- :... --- Couldn't match type ‘...’ with ‘0’ --- Expected type: Vec ... a --- Actual type: Vec 0 a --- In the first argument of ‘head’, namely ‘Nil’ --- In the expression: 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 ‘head’, namely ‘Nil’ +-- In the expression: head Nil +-- In an equation for ‘it’: it = head Nil head :: Vec (n + 1) a -> a head (x `Cons` _) = x @@ -307,11 +328,12 @@ -- >>> tail Nil -- -- :... --- Couldn't match type ‘...’ with ‘0’ --- Expected type: Vec ... a --- Actual type: Vec 0 a --- In the first argument of ‘tail’, namely ‘Nil’ --- In the expression: 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 ‘tail’, namely ‘Nil’ +-- In the expression: tail Nil +-- In an equation for ‘it’: it = tail Nil tail :: Vec (n + 1) a -> Vec n a tail (_ `Cons` xs) = xs @@ -323,11 +345,12 @@ -- >>> last Nil -- -- :... --- Couldn't match type ‘...’ with ‘0’ --- Expected type: Vec ... a --- Actual type: Vec 0 a --- In the first argument of ‘last’, namely ‘Nil’ --- In the expression: 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 ‘last’, namely ‘Nil’ +-- In the expression: last Nil +-- In an equation for ‘it’: it = last Nil last :: Vec (n + 1) a -> a last (x `Cons` Nil) = x last (_ `Cons` y `Cons` ys) = last (y `Cons` ys) @@ -340,11 +363,12 @@ -- >>> init Nil -- -- :... --- Couldn't match type ‘...’ with ‘0’ --- Expected type: Vec ... a --- Actual type: Vec 0 a --- In the first argument of ‘init’, namely ‘Nil’ --- In the expression: 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 ‘init’, namely ‘Nil’ +-- In the expression: init Nil +-- In an equation for ‘it’: it = init Nil init :: Vec (n + 1) a -> Vec n a init (_ `Cons` Nil) = Nil init (x `Cons` y `Cons` ys) = x `Cons` init (y `Cons` ys) @@ -466,12 +490,12 @@ -- -- >>> shiftOutFromN d2 ((1 :> 2 :> 3 :> 4 :> 5 :> Nil) :: Vec 5 Integer) -- (<0,0,1,2,3>,<4,5>) -shiftOutFromN :: (Default a, KnownNat (m + n)) +shiftOutFromN :: (Default a, KnownNat 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) +shiftOutFromN m@SNat xs = shiftInAt0 xs (replicate m def) {-# INLINE shiftOutFromN #-} infixr 5 ++ @@ -486,7 +510,7 @@ -- | Split a vector into two vectors at the given point. -- --- >>> splitAt (snat :: SNat 3) (1:>2:>3:>7:>8:>Nil) +-- >>> 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>) @@ -576,6 +600,7 @@ -- imap (+) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Index 4) -- >>> imap (+) (2 :> 2 :> 2 :> 2 :> Nil) -- <2,3,*** Exception: CLaSH.Sized.Index: result 4 is out of bounds: [0..3] +-- ... -- >>> imap (\i a -> fromIntegral i + a) (2 :> 2 :> 2 :> 2 :> Nil) :: Vec 4 (Unsigned 8) -- <2,3,4,5> -- @@ -594,6 +619,7 @@ -- -- >>> izipWith (\i a b -> i + a + b) (2 :> 2 :> Nil) (3 :> 3:> Nil) -- <*** Exception: CLaSH.Sized.Index: result 3 is out of bounds: [0..1] +-- ... -- >>> izipWith (\i a b -> fromIntegral i + a + b) (2 :> 2 :> Nil) (3 :> 3 :> Nil) :: Vec 2 (Unsigned 8) -- <5,6> -- @@ -992,7 +1018,7 @@ sub Nil _ = error (P.concat [ "CLaSH.Sized.Vector.(!!): index " , show i , " is larger than maximum index " - , show (maxIndex xs) + , show ((length xs)-1) ]) sub (y `Cons` (!ys)) n = if isTrue# (n ==# 0#) then y @@ -1002,28 +1028,27 @@ -- | \"@xs@ '!!' @n@\" returns the /n/'th element of /xs/. -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at 'maxIndex'. +-- ending at @'length' - 1@. -- -- >>> (1:>2:>3:>4:>5:>Nil) !! 4 -- 5 --- >>> (1:>2:>3:>4:>5:>Nil) !! maxIndex (1:>2:>3:>4:>5:>Nil) +-- >>> (1:>2:>3:>4:>5:>Nil) !! (length (1:>2:>3:>4:>5:>Nil) - 1) -- 5 -- >>> (1:>2:>3:>4:>5:>Nil) !! 1 -- 2 -- >>> (1:>2:>3:>4:>5:>Nil) !! 14 -- *** Exception: CLaSH.Sized.Vector.(!!): index 14 is larger than maximum index 4 +-- ... (!!) :: (KnownNat n, Enum i) => Vec n a -> i -> a xs !! i = index_int xs (fromEnum i) {-# INLINE (!!) #-} -- | The index (subscript) of the last element in a 'Vec'tor as an 'Int' -- value. --- --- >>> maxIndex (6 :> 7 :> 8 :> Nil) --- 2 maxIndex :: KnownNat n => Vec n a -> Int maxIndex = subtract 1 . length {-# NOINLINE maxIndex #-} +{-# DEPRECATED maxIndex "'maxIndex' will be removed in clash-prelude-1.0, use 'length xs - 1' instead." #-} -- | The length of a 'Vec'tor as an 'Int' value. -- @@ -1042,7 +1067,7 @@ sub Nil _ _ = error (P.concat [ "CLaSH.Sized.Vector.replace: index " , show i , " is larger than maximum index " - , show (maxIndex xs) + , show (length xs - 1) ]) sub (y `Cons` (!ys)) n b = if isTrue# (n ==# 0#) then b `Cons` ys @@ -1053,7 +1078,7 @@ -- replaced by /a/. -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at 'maxIndex'. +-- ending at @'length' - 1@. -- -- >>> replace 3 7 (1:>2:>3:>4:>5:>Nil) -- <1,2,3,7,5> @@ -1061,13 +1086,14 @@ -- <7,2,3,4,5> -- >>> replace 9 7 (1:>2:>3:>4:>5:>Nil) -- <1,2,3,4,*** Exception: CLaSH.Sized.Vector.replace: index 9 is larger than maximum index 4 +-- ... replace :: (KnownNat n, Enum i) => i -> a -> Vec n a -> Vec n a replace i y xs = replace_int xs (fromEnum i) y {-# INLINE replace #-} -- | \"'take' @n xs@\" returns the /n/-length prefix of /xs/. -- --- >>> take (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) +-- >>> take (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) -- <1,2,3> -- >>> take d3 (1:>2:>3:>4:>5:>Nil) -- <1,2,3> @@ -1076,13 +1102,13 @@ -- >>> 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 ‘take’, namely ‘(1 :> 2 :> Nil)’ --- In the expression: take d4 (1 :> 2 :> Nil) --- In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) +-- • Couldn't match type ‘4 + n0’ with ‘2’ +-- Expected type: Vec (4 + n0) a +-- Actual type: Vec (1 + 1) a +-- The type variable ‘n0’ is ambiguous +-- • In the second argument of ‘take’, namely ‘(1 :> 2 :> Nil)’ +-- In the expression: take d4 (1 :> 2 :> Nil) +-- In an equation for ‘it’: it = take d4 (1 :> 2 :> Nil) take :: SNat m -> Vec (m + n) a -> Vec m a take n = fst . splitAt n {-# INLINE take #-} @@ -1097,7 +1123,7 @@ -- | \"'drop' @n xs@\" returns the suffix of /xs/ after the first /n/ elements. -- --- >>> drop (snat :: SNat 3) (1:>2:>3:>4:>5:>Nil) +-- >>> drop (SNat :: SNat 3) (1:>2:>3:>4:>5:>Nil) -- <4,5> -- >>> drop d3 (1:>2:>3:>4:>5:>Nil) -- <4,5> @@ -1106,10 +1132,10 @@ -- >>> 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 +-- • 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 drop #-} @@ -1125,9 +1151,9 @@ -- | \"'at' @n xs@\" returns /n/'th element of /xs/ -- -- __NB__: vector elements have an __ASCENDING__ subscript starting from 0 and --- ending at 'maxIndex'. +-- ending at @'length' - 1@. -- --- >>> at (snat :: SNat 1) (1:>2:>3:>4:>5:>Nil) +-- >>> at (SNat :: SNat 1) (1:>2:>3:>4:>5:>Nil) -- 2 -- >>> at d1 (1:>2:>3:>4:>5:>Nil) -- 2 @@ -1138,7 +1164,7 @@ -- | \"'select' @f s n xs@\" selects /n/ elements with step-size /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) +-- >>> 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> @@ -1171,7 +1197,7 @@ -- | \"'replicate' @n a@\" returns a vector that has /n/ copies of /a/. -- --- >>> replicate (snat :: SNat 3) 6 +-- >>> replicate (SNat :: SNat 3) 6 -- <6,6,6> -- >>> replicate d3 6 -- <6,6,6> @@ -1187,6 +1213,11 @@ -- demanded by the context. -- -- >>> replicateI 6 :: Vec 5 Int +-- +-- :... +-- In the use of ‘replicateI’ +-- (imported from CLaSH.Prelude, but defined in CLaSH.Sized.Vector): +-- Deprecated: "Use 'repeat' instead of 'replicateI'" -- <6,6,6,6,6> replicateI :: KnownNat n => a -> Vec n a replicateI = withSNat replicate @@ -1205,7 +1236,7 @@ -- | \"'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 (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 @@ -1215,7 +1246,7 @@ -- -- <> iterate :: SNat n -> (a -> a) -> a -> Vec n a -iterate (SNat _) = iterateI +iterate SNat = iterateI {-# INLINE iterate #-} -- | \"'iterate' @f x@\" returns a vector starting with @x@ followed by @n@ @@ -1239,7 +1270,7 @@ -- | \"'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 (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 @@ -1249,7 +1280,7 @@ -- -- <> generate :: SNat n -> (a -> a) -> a -> Vec n a -generate (SNat _) f a = iterateI f (f a) +generate SNat f a = iterateI f (f a) {-# INLINE generate #-} -- | \"'generateI' @f x@\" returns a vector with @n@ repeated applications of @@ -1291,7 +1322,7 @@ -- stencil1d d2 sum xs :: Num b => Vec 5 b -- >>> stencil1d d2 sum xs -- <3,5,7,9,11> -stencil1d :: KnownNat (n + 1) +stencil1d :: KnownNat n => SNat (stX + 1) -- ^ Windows length /stX/, at least size 1 -> (Vec (stX + 1) a -> b) -- ^ The stencil (function) -> Vec ((stX + n) + 1) a @@ -1310,10 +1341,10 @@ -- >>> :t xss -- xss :: Num a => Vec 4 (Vec 4 a) -- >>> :t stencil2d d2 d2 (sum . map sum) xss --- stencil2d d2 d2 (sum . map sum) xss :: Num a => Vec 3 (Vec 3 a) +-- stencil2d d2 d2 (sum . map sum) xss :: Num b => Vec 3 (Vec 3 b) -- >>> stencil2d d2 d2 (sum . map sum) xss -- <<14,18,22>,<30,34,38>,<46,50,54>> -stencil2d :: (KnownNat (n + 1), KnownNat (m+1)) +stencil2d :: (KnownNat n, KnownNat m) => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 -> (Vec (stY + 1) (Vec (stX + 1) a) -> b) -- ^ The stencil (function) @@ -1332,7 +1363,7 @@ -- windows1d d2 xs :: Num a => Vec 5 (Vec 2 a) -- >>> windows1d d2 xs -- <<1,2>,<2,3>,<3,4>,<4,5>,<5,6>> -windows1d :: KnownNat (n + 1) +windows1d :: KnownNat n => SNat (stX + 1) -- ^ Length of the window, at least size 1 -> Vec ((stX + n) + 1) a -> Vec (n + 1) (Vec (stX + 1) a) @@ -1354,13 +1385,12 @@ -- windows2d d2 d2 xss :: Num a => Vec 3 (Vec 3 (Vec 2 (Vec 2 a))) -- >>> windows2d d2 d2 xss -- <<<<1,2>,<5,6>>,<<2,3>,<6,7>>,<<3,4>,<7,8>>>,<<<5,6>,<9,10>>,<<6,7>,<10,11>>,<<7,8>,<11,12>>>,<<<9,10>,<13,14>>,<<10,11>,<14,15>>,<<11,12>,<15,16>>>> -windows2d :: (KnownNat (n+1),KnownNat (m+1)) +windows2d :: (KnownNat n,KnownNat m) => SNat (stY + 1) -- ^ Window hight /stY/, at least size 1 -> SNat (stX + 1) -- ^ Window width /stX/, at least size 1 -> Vec ((stY + m) + 1) (Vec (stX + n + 1) a) -> Vec (m + 1) (Vec (n + 1) (Vec (stY + 1) (Vec (stX + 1) a))) -windows2d stY stX xss = map (transpose . (map (windows1d stX))) - (windows1d stY xss) +windows2d stY stX xss = map (transpose . (map (windows1d stX))) (windows1d stY xss) {-# INLINE windows2d #-} -- | Forward permutation specified by an index mapping, /ix/. The result vector @@ -1547,15 +1577,19 @@ -- | 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) +-- > $(listToVecTH [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]) +-- >>> $(listToVecTH [1::Signed 8,2,3,4,5]) -- <1,2,3,4,5> +listToVecTH :: Lift a => [a] -> ExpQ +listToVecTH [] = [| Nil |] +listToVecTH (x:xs) = [| x :> $(listToVecTH xs) |] + v :: Lift a => [a] -> ExpQ -v [] = [| Nil |] -v (x:xs) = [| x :> $(v xs) |] +v = listToVecTH +{-# DEPRECATED v "'v' will be removed in clash-prelude-1.0, use 'listToVecTH'" #-} -- | 'Vec'tor as a 'Proxy' for 'Nat' asNatProxy :: Vec n a -> Proxy n @@ -1563,7 +1597,7 @@ -- | Length of a 'Vec'tor as an 'SNat' value lengthS :: KnownNat n => Vec n a -> SNat n -lengthS _ = snat +lengthS _ = SNat {-# INLINE lengthS #-} -- | What you should use when your vector functions are too strict in their @@ -1626,33 +1660,36 @@ -- | A /dependently/ typed fold. -- --- Using lists, we can define @append@ ('Prelude.++') using 'Prelude.foldr': +-- Using lists, we can define /append/ (a.k.a. @Data.List.@'Data.List.++') in +-- terms of @Data.List.@'Data.List.foldr': -- --- >>> import qualified Prelude --- >>> let append xs ys = Prelude.foldr (:) ys xs +-- >>> import qualified Data.List +-- >>> let append xs ys = Data.List.foldr (:) ys xs -- >>> append [1,2] [3,4] -- [1,2,3,4] -- --- However, when we try to do the same for 'Vec': +-- However, when we try to do the same for 'Vec', by defining /append'/ in terms +-- of @CLaSH.Sized.Vector.@'foldr': -- -- @ -- append' xs ys = 'foldr' (:>) ys xs -- @ -- --- We get a type error +-- we get a type error: -- -- >>> let append' xs ys = foldr (:>) ys xs -- -- :... --- Occurs check: cannot construct the infinite type: ... ~ ... + 1 --- Expected type: a -> Vec ... a -> Vec ... a --- Actual type: a -> Vec ... a -> Vec (... + 1) a --- Relevant bindings include --- ys :: Vec ... a (bound at ...) --- append' :: Vec n a -> Vec ... a -> Vec ... a --- (bound at ...) --- In the first argument of ‘foldr’, namely ‘(:>)’ --- In the expression: foldr (:>) ys xs +-- • Occurs check: cannot construct the infinite type: t ~ t + 1 +-- Expected type: a -> Vec t a -> Vec t a +-- Actual type: a -> Vec t a -> Vec (t + 1) a +-- • In the first argument of ‘foldr’, namely ‘(:>)’ +-- In the expression: foldr (:>) ys xs +-- In an equation for ‘append'’: append' xs ys = foldr (:>) ys xs +-- • Relevant bindings include +-- ys :: Vec t a (bound at ...) +-- append' :: Vec n a -> Vec t a -> Vec t a +-- (bound at ...) -- -- The reason is that the type of 'foldr' is: -- @@ -1667,8 +1704,8 @@ -- We thus need a @fold@ function that can handle the growing vector type: -- 'dfold'. Compared to 'foldr', 'dfold' takes an extra parameter, called the -- /motive/, that allows the folded function to have an argument and result type --- that /depends/ on the current index into the vector. Using 'dfold', we can --- now correctly define ('++'): +-- that /depends/ on the current length of the vector. Using 'dfold', we can +-- now correctly define /append'/: -- -- @ -- import Data.Singletons.Prelude @@ -1680,7 +1717,7 @@ -- append' xs ys = 'dfold' (Proxy :: Proxy (Append m a)) (const (':>')) ys xs -- @ -- --- We now see that @append'@ has the appropriate type: +-- We now see that /append'/ has the appropriate type: -- -- >>> :t append' -- append' :: KnownNat k => Vec k a -> Vec m a -> Vec (k + m) a @@ -1689,25 +1726,159 @@ -- -- >>> append' (1 :> 2 :> Nil) (3 :> 4 :> Nil) -- <1,2,3,4> +-- +-- __NB__: \"@'dfold' m f z xs@\" creates a linear structure, which has a depth, +-- or delay, of O(@'length' xs@). Look at 'dtfold' for a /dependently/ typed +-- fold that produces a structure with a depth of O(log_2(@'length' xs@)). dfold :: forall p k a . KnownNat k => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ - -> (forall l . SNat l -> a -> (p $ l) -> (p $ (l + 1))) -- ^ Function to fold - -> (p $ 0) -- ^ Initial element + -> (forall l . SNat l -> a -> (p @@ l) -> (p @@ (l + 1))) + -- ^ Function to fold. + -- + -- __NB__: The @SNat l@ is __not__ the index (see (`!!`)) to the + -- element /a/. @SNat l@ is the number of elements that occur to the + -- right of /a/. + -> (p @@ 0) -- ^ Initial element -> Vec k a -- ^ Vector to fold over - -> (p $ k) -dfold _ f z xs = go (natVal (asNatProxy xs) - 1) xs + -> (p @@ k) +dfold _ f z xs = go (snatProxy (asNatProxy xs)) xs where - go :: Integer -> Vec n a -> (p $ n) + go :: SNat n -> Vec n a -> (p @@ n) go _ Nil = z - go i (y `Cons` (ys :: Vec z a)) = f (unsafeSNat i :: SNat z) y (go (i-1) ys) + go s (y `Cons` (ys :: Vec z a)) = + let s' = s `subSNat` d1 + in f s' y (go s' ys) {-# NOINLINE dfold #-} +-- | A combination of 'dfold' and 'fold': a /dependently/ typed fold that +-- reduces a vector in a tree-like structure. +-- +-- As an example of when you might want to use 'dtfold' we will build a +-- population counter: a circuit that counts the number of bits set to '1' in +-- a 'BitVector'. Given a vector of /n/ bits, we only need we need a data type +-- that can represent the number /n/: 'Index' @(n+1)@. 'Index' @k@ has a range +-- of @[0 .. k-1]@ (using @ceil(log2(k))@ bits), hence we need 'Index' @n+1@. +-- As an initial attempt we will use 'sum', because it gives a nice (@log2(n)@) +-- tree-structure of adders: +-- +-- @ +-- populationCount :: (KnownNat (n+1), KnownNat (n+2)) +-- => 'BitVector' (n+1) -> 'Index' (n+2) +-- populationCount = sum . map fromIntegral . 'bv2v' +-- @ +-- +-- The \"problem\" with this description is that all adders have the same +-- bit-width, i.e. all adders are of the type: +-- +-- @ +-- (+) :: 'Index' (n+2) -> 'Index' (n+2) -> 'Index' (n+2). +-- @ +-- +-- This is a \"problem\" because we could have a more efficient structure: +-- one where each layer of adders is /precisely/ wide enough to count the number +-- of bits at that layer. That is, at height /d/ we want the adder to be of +-- type: +-- +-- @ +-- 'Index' ((2^d)+1) -> 'Index' ((2^d)+1) -> 'Index' ((2^(d+1))+1) +-- @ +-- +-- We have such an adder in the form of the 'CLaSH.Class.Num.plus' function, as +-- defined in the instance 'CLaSH.Class.Num.ExtendingNum' instance of 'Index'. +-- However, we cannot simply use 'fold' to create a tree-structure of +-- 'CLaSH.Class.Num.plus'es: +-- +-- >>> :{ +-- let populationCount' :: (KnownNat (n+1), KnownNat (n+2)) +-- => BitVector (n+1) -> Index (n+2) +-- populationCount' = fold plus . map fromIntegral . bv2v +-- :} +-- +-- :... +-- • Couldn't match type ‘((n + 2) + (n + 2)) - 1’ with ‘n + 2’ +-- Expected type: Index (n + 2) -> Index (n + 2) -> Index (n + 2) +-- Actual type: Index (n + 2) +-- -> Index (n + 2) -> AResult (Index (n + 2)) (Index (n + 2)) +-- • In the first argument of ‘fold’, namely ‘plus’ +-- In the first argument of ‘(.)’, namely ‘fold plus’ +-- In the expression: fold plus . map fromIntegral . bv2v +-- • Relevant bindings include +-- populationCount' :: BitVector (n + 1) -> Index (n + 2) +-- (bound at ...) +-- +-- because 'fold' expects a function of type \"@a -> a -> a@\", i.e. a function +-- where the arguments and result all have exactly the same type. +-- +-- In order to accommodate the type of our 'CLaSH.Class.Num.plus', where the +-- result is larger than the arguments, we must use a dependently typed fold in +-- the the form of 'dtfold': +-- +-- @ +-- {\-\# LANGUAGE UndecidableInstances \#-\} +-- import Data.Singletons.Prelude +-- import Data.Proxy +-- +-- data IIndex (f :: 'TyFun' Nat *) :: * +-- type instance 'Apply' IIndex l = 'Index' ((2^l)+1) +-- +-- populationCount' :: (KnownNat k, KnownNat (2^k)) +-- => BitVector (2^k) -> Index ((2^k)+1) +-- populationCount' bv = 'dtfold' (Proxy @IIndex) +-- fromIntegral +-- (\\_ x y -> 'CLaSH.Class.Num.plus' x y) +-- ('bv2v' bv) +-- @ +-- +-- And we can test that it works: +-- +-- >>> :t populationCount' (7 :: BitVector 16) +-- populationCount' (7 :: BitVector 16) :: Index 17 +-- >>> populationCount' (7 :: BitVector 16) +-- 3 +-- +-- Some final remarks: +-- +-- * By using 'dtfold' instead of 'fold', we had to restrict our 'BitVector' +-- argument to have bit-width that is a power of 2. +-- * Even though our original /populationCount/ function specified a structure +-- where all adders had the same width. Most VHDL/(System)Verilog synthesis +-- tools will create a more efficient circuit, i.e. one where the adders +-- have an increasing bit-width for every layer, from the +-- VHDL/(System)Verilog produced by the CLaSH compiler. +-- +-- __NB__: The depth, or delay, of the structure produced by +-- \"@'dtfold' m f g xs@\" is O(log_2(@'length' xs@)). +dtfold :: forall p k a . KnownNat k + => Proxy (p :: TyFun Nat * -> *) -- ^ The /motive/ + -> (a -> (p @@ 0)) -- ^ Function to apply to every element + -> (forall l . SNat l -> (p @@ l) -> (p @@ l) -> (p @@ (l + 1))) + -- ^ Function to combine results. + -- + -- __NB__: The @SNat l@ indicates the depth/height of the node in the + -- tree that is created by applying this function. The leafs of the tree + -- have depth\/height /0/, and the root of the tree has height /k/. + -> Vec (2^k) a + -- ^ Vector to fold over. + -- + -- __NB__: Must have a length that is a power of 2. + -> (p @@ k) +dtfold _ f g = go (SNat :: SNat k) + where + go :: forall n . SNat n -> Vec (2^n) a -> (p @@ n) + go _ (x `Cons` Nil) = f x + go sn xs = + let sn' :: SNat (n - 1) + sn' = sn `subSNat` d1 + (xsL,xsR) = splitAt (pow2SNat sn') xs + in g sn' (go sn' xsL) (go sn' xsR) +{-# NOINLINE dtfold #-} + -- | To be used as the motive /p/ for 'dfold', when the /f/ in \"'dfold' @p f@\" -- is a variation on (':>'), e.g.: -- -- @ --- map' :: KnownNat k => (a -> b) -> Vec n a -> Vec n b --- map' f = 'dfold' (Proxy :: Proxy ('VCons' a)) (\_ x xs -> f x :> xs) +-- map' :: forall n a b . KnownNat n => (a -> b) -> Vec n a -> Vec n b +-- map' f = 'dfold' (Proxy @('VCons' b)) (\_ x xs -> f x :> xs) -- @ data VCons (a :: *) (f :: TyFun Nat *) :: * type instance Apply (VCons a) l = Vec l a @@ -1720,7 +1891,7 @@ -- @ -- compareSwap a b = if a > b then (a,b) else (b,a) -- insert y xs = let (y',xs') = 'mapAccumL' compareSwap y xs in xs' ':<' y' --- insertionSort = 'vfold' insert +-- insertionSort = 'vfold' (const insert) -- @ -- -- Builds a triangular structure of compare and swaps to sort a row. @@ -1731,11 +1902,11 @@ -- The circuit layout of @insertionSort@, build using 'vfold', is: -- -- <> -vfold :: KnownNat k - => (forall l . a -> Vec l b -> Vec (l + 1) b) +vfold :: forall k a b . KnownNat k + => (forall l . SNat l -> a -> Vec l b -> Vec (l + 1) b) -> Vec k a -> Vec k b -vfold f xs = dfold (Proxy :: Proxy (VCons a)) (const f) Nil xs +vfold f xs = dfold (Proxy @(VCons b)) f Nil xs {-# INLINE vfold #-} -- | Apply a function to every element of a vector and the element's position @@ -1747,12 +1918,11 @@ -- <<1,2,3>,<1,2,3>,<1,2,3>> -- >>> rotateMatrix xss -- <<1,2,3>,<3,1,2>,<2,3,1>> -smap :: KnownNat k => (forall l . SNat (k-1-l) -> a -> b) -> Vec k a -> Vec k b -smap f xs = dfold (Proxy :: Proxy (VCons a)) - (\sn x xs' -> f (xsL `subSNat` d1 `subSNat` sn) x :> xs') - Nil xs - where - xsL = lengthS xs +smap :: forall k a b . KnownNat k => (forall l . SNat l -> a -> b) -> Vec k a -> Vec k b +smap f xs = reverse + $ dfold (Proxy @(VCons b)) + (\sn x xs' -> f sn x :> xs') + Nil (reverse xs) {-# INLINE smap #-} instance (KnownNat n, KnownNat (BitSize a), BitPack a) => BitPack (Vec n a) where @@ -1807,7 +1977,7 @@ instance Lift a => Lift (Vec n a) where lift Nil = [| Nil |] - lift (x `Cons` xs) = [| x :> $(lift xs) |] + lift (x `Cons` xs) = [| x `Cons` $(lift xs) |] instance (KnownNat n, Arbitrary a) => Arbitrary (Vec n a) where arbitrary = traverse# id $ repeat arbitrary @@ -1816,7 +1986,7 @@ instance CoArbitrary a => CoArbitrary (Vec n a) where coarbitrary = coarbitrary . toList -type instance Lens.Index (Vec n a) = Int +type instance Lens.Index (Vec n a) = Index n type instance Lens.IxValue (Vec n a) = a instance KnownNat n => Lens.Ixed (Vec n a) where - ix i f xs = replace_int xs i <$> f (index_int xs i) + ix i f xs = replace_int xs (fromEnum i) <$> f (index_int xs (fromEnum i)) diff --git a/src/CLaSH/Sized/Vector.hs-boot b/src/CLaSH/Sized/Vector.hs-boot --- a/src/CLaSH/Sized/Vector.hs-boot +++ b/src/CLaSH/Sized/Vector.hs-boot @@ -19,5 +19,7 @@ instance (KnownNat m, (~) m ((+) n 1)) => Foldable (Vec m) -bv2v :: KnownNat n => BitVector n -> Vec n Bit -map :: (a -> b) -> Vec n a -> Vec n b +bv2v :: KnownNat n => BitVector n -> Vec n Bit +map :: (a -> b) -> Vec n a -> Vec n b +foldr :: (a -> b -> b) -> b -> Vec n a -> b +foldl :: (b -> a -> b) -> b -> Vec n a -> b diff --git a/src/CLaSH/Tutorial.hs b/src/CLaSH/Tutorial.hs --- a/src/CLaSH/Tutorial.hs +++ b/src/CLaSH/Tutorial.hs @@ -1,5 +1,5 @@ {-| -Copyright : © Christiaan Baaij, 2014-2016 +Copyright : © 2014-2016, Christiaan Baaij, 2017, QBayLogic Licence : Creative Commons 4.0 (CC BY 4.0) (http://creativecommons.org/licenses/by/4.0/) -} @@ -77,6 +77,7 @@ import Data.Char import Data.Int import GHC.Prim +import GHC.TypeLits import GHC.Word import Data.Default @@ -112,8 +113,8 @@ >>> let mac = mealy macT 0 >>> let topEntity = mac :: Signal (Signed 9, Signed 9) -> Signal (Signed 9) ->>> let testInput = stimuliGenerator $(v [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)]) ->>> let expectedOutput = outputVerifier $(v [0 :: Signed 9,1,5,14]) +>>> let testInput = stimuliGenerator $(listToVecTH [(1,1) :: (Signed 9,Signed 9),(2,2),(3,3),(4,4)]) +>>> let expectedOutput = outputVerifier $(listToVecTH [0 :: Signed 9,1,5,14]) >>> :{ let fibR :: Unsigned 64 -> Unsigned 64 fibR 0 = 0 @@ -139,9 +140,8 @@ Features of CλaSH: - * Strongly typed (like VHDL), yet with a very high degree of type inference, - enabling both safe and fast prototying using concise descriptions (like - Verilog). + * Strongly typed, but with a very high degree of type inference, enabling + both safe and fast prototyping using concise descriptions. * Interactive REPL: load your designs in an interpreter and easily test all your component without needing to setup a test bench. * Compile your designs for fast simulation. @@ -188,37 +188,40 @@ {- $installation The CλaSH compiler and Prelude library for circuit design only work with the - Haskell compiler version 7.10 (higher or lower -versions of GHC are not supported). + Haskell compiler version 8.0 (lower versions of +GHC are not supported). - (1) Install __GHC 7.10__ + (1) Install __GHC 8.0__ - * Download and install . + * Download and install . Unix user can use @./configure prefix=\@ to set the installation location. * Make sure that the @bin@ directory of __GHC__ is in your @PATH@. - Next follows a list of alternative installation instructions, in case you cannot find what you are looking for on + In case you cannot find what you are looking for on , + you can, /alternatively/, use the following instructions: * Ubuntu: * Run: @sudo add-apt-repository -y ppa:hvr/ghc@ * Run: @sudo apt-get update@ - * Run: @sudo apt-get install cabal-install-1.24 ghc-7.10.3 libtinfo-dev@ - * Update your @PATH@ with: @\/opt\/ghc\/7.10.3\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@ + * Run: @sudo apt-get install cabal-install-1.24 ghc-8.0.2 libtinfo-dev@ + * Update your @PATH@ with: @\/opt\/ghc\/8.0.2\/bin@, @\/opt\/cabal\/1.24/bin@, and @\$HOME\/.cabal\/bin@ * Run: @cabal update@ * Skip step 2. * OS X: - * Follow the instructions on: + * Follow the instructions on: + to install the /minimal/ Haskell platform * Run: @cabal update@ * Skip step 2. * Windows: - * Follow the instructions on: + * Follow the instructions on: + to install the /minimal/ Haskell platform * Run: @cabal update@ * Skip step 2. @@ -253,7 +256,7 @@ (4) Verify that everything is working by: - * Downloading the example + * Downloading the example * Run: @clash --interactive FIR.hs@ * Execute, in the interpreter, the @:vhdl@ command * Execute, in the interpreter, the @:verilog@ command @@ -447,8 +450,8 @@ argument is the initial state, in this case 0. We can see it is functioning correctly in our interpreter: ->>> import qualified Data.List ->>> Data.List.take 4 $ simulate mac [(1::Int,1),(2,2),(3,3),(4,4)] :: [Int] +>>> import qualified Data.List as L +>>> L.take 4 $ simulate mac [(1,1),(2,2),(3,3),(4,4)] [0,1,5,14] Where we simulate our sequential circuit over a list of input samples and take @@ -552,10 +555,10 @@ @ testInput :: 'Signal' ('Signed' 9,'Signed' 9) -testInput = 'stimuliGenerator' $('v' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)]) +testInput = 'stimuliGenerator' $('listToVecTH' [(1,1) :: ('Signed' 9,'Signed' 9),(2,2),(3,3),(4,4)]) expectedOutput :: 'Signal' ('Signed' 9) -> 'Signal' Bool -expectedOutput = 'outputVerifier' $('v' [0 :: 'Signed' 9,1,5,14]) +expectedOutput = 'outputVerifier' $('listToVecTH' [0 :: 'Signed' 9,1,5,14]) @ This will create a stimulus generator that creates the same inputs as we used @@ -564,16 +567,16 @@ simulate the behaviour of the /testbench/: >>> sampleN 7 $ expectedOutput (topEntity testInput) -[False,False,False,False, +[False,False,False,False cycle(system1000): 4, outputVerifier expected value: 14, not equal to actual value: 30 -True, +,True cycle(system1000): 5, outputVerifier expected value: 14, not equal to actual value: 46 -True, +,True cycle(system1000): 6, outputVerifier expected value: 14, not equal to actual value: 62 -True] +,True] We can see that for the first 4 samples, everything is working as expected, after which warnings are being reported. The reason is that 'stimuliGenerator' @@ -773,8 +776,8 @@ @ instance 'Bundle' (a,b) where type 'Unbundled'' clk (a,b) = ('Signal'' clk a, 'Signal'' clk b) - bundle' _ (a,b) = (,) '<$>' a '<*>' b - unbundle' _ tup = (fst '<$>' tup, snd '<*>' tup) + bundle (a,b) = (,) '<$>' a '<*>' b + unbundle tup = (fst '<$>' tup, snd '<*>' tup) @ but, @@ -782,8 +785,8 @@ @ instance 'Bundle' Bool where type 'Unbundled'' clk Bool = 'Signal'' clk Bool - bundle' _ s = s - unbundle' _ s = s + bundle s = s + unbundle s = s @ What you need take away from the above is that a product type (e.g. a tuple) of @@ -1004,9 +1007,9 @@ "CLaSH.Sized.Internal.Signed" module specifies multiplication as follows: @ -{\-\# NOINLINE (*#) \#-\} (*#) :: 'GHC.TypeLits.KnownNat' n => 'Signed' n -> 'Signed' n -> 'Signed' n (S a) *# (S b) = fromInteger_INLINE (a * b) +{\-\# NOINLINE (*#) \#-\} @ For which the VHDL /expression/ primitive is: @@ -1046,73 +1049,94 @@ We will use 'blockRam#' as an example, for which the Haskell/CλaSH code is: @ -{\-\# NOINLINE blockRam# \#-\} -- | blockRAM primitive -blockRam# :: 'GHC.TypeLits.KnownNat' n - => 'SClock' clk -- ^ \'Clock\' to synchronize to +blockRam# :: 'KnownNat' n + => 'SClock' clk -- ^ 'Clock' to synchronize to -> 'Vec' n a -- ^ Initial content of the BRAM, also - -- determines the size, \@n\@, of the BRAM. + -- determines the size, @n@, of the BRAM. -- - -- \_\_NB\_\_: \_\_MUST\_\_ be a constant. - -> 'Signal'' clk 'Int' -- ^ Write address \@w\@ - -> 'Signal'' clk 'Int' -- ^ Read address \@r\@ + -- __NB__: __MUST__ be a constant. + -> 'Signal'' clk Int -- ^ Read address @r@ -> 'Signal'' clk Bool -- ^ Write enable - -> 'Signal'' clk a -- ^ Value to write (at address \@w\@) + -> 'Signal'' clk Int -- ^ Write address @w@ + -> 'Signal'' clk a -- ^ Value to write (at address @w@) -> 'Signal'' clk a - -- ^ Value of the \@blockRAM\@ at address \@r\@ from the previous clock + -- ^ Value of the @blockRAM@ at address @r@ from the previous clock -- cycle -blockRam# clk binit wr rd en din = 'register'' clk undefined dout +blockRam# clk content rd en wr din = + 'register'' clk ('errorX' "blockRam#: intial value undefined") dout where - szI = fromInteger $ 'maxIndex' content + szI = 'length' content dout = runST $ do - arr <- newListArray (0,szI) ('toList' content) - traverse (ramT arr) ('bundle'' clk (wr,rd,en,din)) + arr <- newListArray (0,szI-1) ('toList' content) + traverse (ramT arr) ('bundle' (rd,en,wr,din)) - ramT :: STArray s Int e -> (Int,Int,Bool,e) -> ST s e - ramT ram (w,r,e,d) = do - d' <- readArray ram r + 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' +{\-\# NOINLINE blockRam# \#-\} @ And for which the /declaration/ primitive is: @ { \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + , "type" : +"blockRam# :: KnownNat n -- ARG[0] + => SClock clk -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal' clk Int -- rd, ARG[3] + -> Signal' clk Bool -- wren, ARG[4] + -> Signal' clk Int -- wr, ARG[5] + -> Signal' clk a -- din, ARG[6] + -> Signal' clk a" , "templateD" : -"blockRam_~COMPNAME_~SYM[0] : block - signal RAM : ~TYP[2] := ~LIT[2]; - signal dout : ~TYP[6]; - signal wr : integer range 0 to ~LIT[0] - 1; - signal rd : integer range 0 to ~LIT[0] - 1; +"-- blockRam begin +~GENSYM[~COMPNAME_blockRam][0] : block + signal ~GENSYM[RAM][1] : ~TYP[2] := ~LIT[2];~IF ~VIVADO ~THEN + signal ~GENSYM[dout][2] : std_logic_vector(~SIZE[~TYP[6]]-1 downto 0);~ELSE + signal ~SYM[2] : ~TYP[6];~FI + signal ~GENSYM[rd][3] : integer range 0 to ~LIT[0] - 1; + signal ~GENSYM[wr][4] : integer range 0 to ~LIT[0] - 1; begin - wr <= ~ARG[3] + ~SYM[3] <= to_integer(~ARG[3]) -- pragma translate_off - mod ~LIT[0] + mod ~LIT[0] -- pragma translate_on - ; + ; - rd <= ~ARG[4] + ~SYM[4] <= to_integer(~ARG[5]) -- pragma translate_off - mod ~LIT[0] + mod ~LIT[0] -- pragma translate_on - ; + ; - blockRam_~SYM[1] : process(~CLK[1]) + ~GENSYM[blockRam_sync][5] : process(~CLK[1]) begin if rising_edge(~CLK[1]) then - if ~ARG[5] then - RAM(wr) <= ~ARG[6]; + if ~ARG[4] then~IF ~VIVADO ~THEN + ~SYM[1](~SYM[4]) <= ~TOBV[~ARG[6]][~TYP[6]];~ELSE + ~SYM[1](~SYM[4]) <= ~ARG[6];~FI end if; - dout <= RAM(rd); + ~SYM[2] <= ~SYM[1](~SYM[3]); end if; - end process; - - ~RESULT <= dout; -end block;" + end process;~IF ~VIVADO ~THEN + ~RESULT <= ~FROMBV[~SYM[2]][~TYPO];~ELSE + ~RESULT <= ~SYM[2];~FI +end block; +-- blockRam end" } - } +} @ Again, the @name@ of the primitive is the fully qualified name of the function @@ -1139,9 +1163,10 @@ * @~TYPM@: VHDL type/name/ of the result; used in /type qualification/. * @~ERROR[N]@: Error value for the VHDL type of the @(N+1)@'th argument. * @~ERRORO@: Error value for the VHDL type of the result. -* @~SYM[N]@: Randomly generated, but unique, symbol. Multiple occurrences of - @~SYM[N]@ in the same primitive definition all refer to the same random, but - unique, symbol. +* @~GENSYM[\][N]@: Create a unique name, trying to stay as close to + the given @\@ as possible. This unique symbol can be referred to in + other places using @~SYM[N]@. +* @~SYM[N]@: a reference to the unique symbol created by @~GENSYM[\][N]@. * @~SIGD[\][N]@: Create a signal declaration, using @\@ as the name of the signal, and the type of the @(N+1)@'th argument. * @~SIGDO[\]@: Create a signal declaration, using @\@ as the name @@ -1150,9 +1175,25 @@ The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. * @~COMPNAME@: The name of the component in which the primitive is instantiated. * @~LENGTH[\]@: The vector length of the type represented by @\@. +* @~DEPTH[\]@: The tree depth of the type represented by @\@. The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. * @~SIZE[\]@: The number of bits needed to encode the type represented by @\@. The content of @\@ must either be: @TYPM[N]@, @TYPO@, or @TYPELEM[\]@. +* @~IF \ ~THEN \ ~ELSE \ ~FI@: renders the \ + part when \ evaluates to /0/, and renders the \ in all + other cases. Valid @\@s are @~LENGTH[\]@, @~SIZE[\]@, + @~DEPTH[\]@, and @~VIVADO@. +* @~VIVADO@: /1/ when CλaSH compiler is invoked with the @-clash-xilinx@ or + @-clash-vivado@ flag. To be used with in an @~IF .. ~THEN .. ~ElSE .. ~FI@ + statement. +* @~FROMBV[\][\]@: create conversion code that so that the + expression in @\@ is converted to a bit vector (@std_logic_vector@). + The @\@ hole indicates the type of the expression and must be either + @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. +* @~TOBV[\][\]@: create conversion code that so that the + expression in @\@, which has a bit vector (@std_logic_vector@) type, is + converted to type indicated by @\@. The @\@ hole indicates the + must be either @~TYP[N]@, @~TYPO@, or @~TYPELEM[\]@. Some final remarks to end this section: VHDL primitives are there to instruct the CλaSH compiler to use the given VHDL template, instead of trying to do normal @@ -1183,33 +1224,43 @@ @ { \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + , "type" : +"blockRam# :: KnownNat n -- ARG[0] + => SClock clk -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal' clk Int -- rd, ARG[3] + -> Signal' clk Bool -- wren, ARG[4] + -> Signal' clk Int -- wr, ARG[5] + -> Signal' clk a -- din, ARG[6] + -> Signal' clk a" , "templateD" : "// blockRam begin -reg ~TYPO RAM_~SYM[0] [0:~LIT[0]-1]; -reg ~TYPO dout_~SYM[1]; +reg ~TYPO ~GENSYM[RAM][0] [0:~LIT[0]-1]; +reg ~TYPO ~GENSYM[dout][1]; -reg ~TYP[2] ram_init_~SYM[2]; -integer ~SYM[3]; +reg ~TYP[2] ~GENSYM[ram_init][2]; +integer ~GENSYM[i][3]; initial begin - ram_init_~SYM[2] = ~ARG[2]; + ~SYM[2] = ~ARG[2]; for (~SYM[3]=0; ~SYM[3] < ~LIT[0]; ~SYM[3] = ~SYM[3] + 1) begin - RAM_~SYM[0][~LIT[0]-1-~SYM[3]] = ram_init_~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; + ~SYM[0][~LIT[0]-1-~SYM[3]] = ~SYM[2][~SYM[3]*~SIZE[~TYPO]+:~SIZE[~TYPO]]; end end -always @(posedge ~CLK[1]) begin : blockRam_~COMPNAME_~SYM[4] - if (~ARG[5]) begin - RAM_~SYM[0][~ARG[3]] <= ~ARG[6]; +always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][4] + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~ARG[6]; end - dout_~SYM[1] <= RAM_~SYM[0][~ARG[4]]; + ~SYM[1] <= ~SYM[0][~ARG[3]]; end -assign ~RESULT = dout_~SYM[1]; +assign ~RESULT = ~SYM[1]; // blockRam end" } - } +} @ + -} {- $svprimitives @@ -1227,24 +1278,31 @@ @ { \"BlackBox\" : - { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + { "name" : "CLaSH.Prelude.BlockRam.blockRam#" + , "type" : +"blockRam# :: KnownNat n -- ARG[0] + => SClock clk -- clk, ARG[1] + -> Vec n a -- init, ARG[2] + -> Signal' clk Int -- rd, ARG[3] + -> Signal' clk Bool -- wren, ARG[4] + -> Signal' clk Int -- wr, ARG[5] + -> Signal' clk a -- din, ARG[6] + -> Signal' clk a" , "templateD" : -"// blockRam -~SIGD[RAM_~SYM[0]][2]; -~SIGD[dout_~SYM[1]][6]; - +"// blockRam begin +~SIGD[~GENSYM[RAM][0]][2]; +logic [~SIZE[~TYP[6]]-1:0] ~GENSYM[dout][1]; initial begin - ~SYM[0] = ~LIT[3]; + ~SYM[0] = ~LIT[2]; end - -always @(posedge ~CLK[1]) begin : blockRam_~COMPNAME_~SYM[3] - if (~ARG[5]) begin - RAM_~SYM[0][~ARG[3]] <= ~ARG[6]; +always @(posedge ~CLK[1]) begin : ~GENSYM[~COMPNAME_blockRam][2] + if (~ARG[4]) begin + ~SYM[0][~ARG[5]] <= ~TOBV[~ARG[6]][~TYP[6]]; end - dout_~SYM[1] <= RAM_~SYM[0][~ARG[4]]; + ~SYM[1] <= ~SYM[0][~ARG[3]]; end - -assign ~RESULT = dout_~SYM[1];" +assign ~RESULT = ~FROMBV[~SYM[1]][~TYP[6]]; +// blockRam end" } } @ @@ -1297,6 +1355,7 @@ import CLaSH.Prelude import CLaSH.Prelude.Explicit +import Data.Maybe (isJust) @ Then we'll start with the /heart/ of the FIFO synchroniser, an asynchronous RAM @@ -1306,14 +1365,14 @@ synchronous logic. As a consequence, we see in the type signature of 'asyncRam'': @ -__asyncRam'__ :: _ => SClock wclk -- ^ Clock to which to synchronise the write port of the RAM - -> SClock rclk -- ^ Clock to which the read address signal __r__ is synchronised - -> SNat n -- ^ Size __n__ of the RAM - -> Signal' wclk addr -- ^ Write address __w__ - -> Signal' rclk addr -- ^ Read address __r__ - -> Signal' wclk Bool -- ^ Write enable - -> Signal' wclk a -- ^ Value to write (at address __w__) - -> Signal' rclk a -- ^ Value of the RAM at address __r__ +__asyncRam'__ + :: _ + => SClock wclk -- ^ Clock to which to synchronise the write port of the RAM + -> SClock rclk -- ^ Clock to which the read address signal __r__ is synchronised + -> SNat n -- ^ Size __n__ of the RAM + -> Signal' rclk addr -- ^ Read address __r__ + -> Signal' wclk (Maybe (addr,a)) -- ^ (write address @w@, value to write) + -> Signal' rclk a -- ^ Value of the RAM at address __r__ @ that the signal containing the read address __r__ is synchronised to a different @@ -1322,12 +1381,13 @@ We continue by instantiating the 'asyncRam'': @ -fifoMem wclk rclk addrSize waddr raddr winc wfull wdata = +fifoMem wclk rclk addrSize wfull raddr wdataM = 'asyncRam'' wclk rclk - (d2 ``powSNat`` addrSize) - waddr raddr - (winc '.&&.' 'not1' wfull) - wdata + ('pow2SNat' addrSize) + raddr + ('mux' (not \<$\> wfull) + wdataM + (pure Nothing)) @ We see that we give it @2^addrSize@ elements, where @addrSize@ is the bit-size @@ -1337,24 +1397,17 @@ 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 -or empty. We start with a function that converts 'Bool'eans to @n + 1@ bit -bitvectors: - -@ -boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1) -boolToBV = 'zeroExtend' . 'pack' -@ - -followed by the actual address and flag generator in 'mealy' machine style: +or empty. The address and flag generator is given in 'mealy' machine style: @ -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') - ,(flag,addr,ptr)) +ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = + ((bin',ptr',flag') + ,(flag,addr,ptr)) where -- GRAYSTYLE2 pointer - bin' = bin + boolToBV (inc && not flag) + bin' = bin + 'boolToBV' (inc && not flag) ptr' = (bin' \`shiftR\` 1) \`xor\` bin' - addr = 'slice' (addrSize ``subSNat`` d1) d0 bin + addr = 'slice' (addrSize ``subSNat`` d1) d0 bin flag' = flagGen ptr' s_ptr @ @@ -1375,8 +1428,10 @@ rptrEmptyInit = (0,0,True) -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} -isFull addrSize ptr s_ptr = ptr == ('complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' - 'slice' (addrSize ``subSNat`` d2) d0 s_ptr) +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) @ @@ -1399,28 +1454,32 @@ Finally we combine all the component in: @ -fifo :: _ - => SNat addrSize -> SClock wclk -> SClock rclk - -> Signal' wclk a -> Signal' wclk Bool - -> Signal' rclk Bool - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) -fifo addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull) +fifo + :: _ + => SNat (addrSize + 2) + -> SClock wclk + -> SClock rclk + -> Signal' rclk Bool + -> Signal' wclk (Maybe a) + -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) +fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = ptrSync rclk wclk rptr s_wptr = ptrSync wclk rclk wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata + rdata = fifoMem wclk rclk addrSize wfull raddr + (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit (s_wptr,rinc) (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize)) - wptrFullInit (s_rptr,winc) + wptrFullInit (s_rptr,isJust \<$\> wdataM) @ where we first specify the synchronisation of the read and the write pointers, -instantiate the asynchronous RAM, and instantiate the read address/pointer/flag -generator and write address/pointer/flag generator. +instantiate the asynchronous RAM, and instantiate the read address \/ pointer \/ +flag generator and write address \/ pointer \/ flag generator. Ultimately, the whole file containing our FIFO design will look like this: @@ -1431,22 +1490,22 @@ import CLaSH.Prelude import CLaSH.Prelude.Explicit +import Data.Maybe (isJust) -fifoMem wclk rclk addrSize waddr raddr winc wfull wdata = +fifoMem wclk rclk addrSize wfull raddr wdataM = 'asyncRam'' wclk rclk - (d2 ``powSNat`` addrSize) - waddr raddr - (winc '.&&.' 'not1' wfull) - wdata - -boolToBV :: (KnownNat n, KnownNat (n+1)) => Bool -> BitVector (n + 1) -boolToBV = 'zeroExtend' . 'pack' + ('pow2SNat' addrSize) + raddr + ('mux' (not \<$\> wfull) + wdataM + (pure Nothing)) -ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = ((bin',ptr',flag') - ,(flag,addr,ptr)) +ptrCompareT addrSize flagGen (bin,ptr,flag) (s_ptr,inc) = + ((bin',ptr',flag') + ,(flag,addr,ptr)) where -- GRAYSTYLE2 pointer - bin' = bin + boolToBV (inc && not flag) + bin' = bin + 'boolToBV' (inc && not flag) ptr' = (bin' \`shiftR\` 1) \`xor\` bin' addr = 'slice' (addrSize ``subSNat`` d1) d0 bin @@ -1457,8 +1516,10 @@ rptrEmptyInit = (0,0,True) -- FIFO full: when next pntr == synchonized {~wptr[addrSize:addrSize-1],wptr[addrSize-1:0]} -isFull addrSize ptr s_ptr = ptr == ('complement' ('slice' addrSize (addrSize ``subSNat`` d1) s_ptr) '++#' - 'slice' (addrSize ``subSNat`` d2) d0 s_ptr) +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 @@ -1467,23 +1528,27 @@ . 'unsafeSynchronizer' clk1 clk2 -- Async FIFO synchroniser -fifo :: _ - => SNat addrSize -> SClock wclk -> SClock rclk - -> Signal' wclk a -> Signal' wclk Bool - -> Signal' rclk Bool - -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) -fifo addrSize wclk rclk wdata winc rinc = (rdata,rempty,wfull) +fifo + :: _ + => SNat (addrSize + 2) + -> SClock wclk + -> SClock rclk + -> Signal' rclk Bool + -> Signal' wclk (Maybe a) + -> (Signal' rclk a, Signal' rclk Bool, Signal' wclk Bool) +fifo addrSize wclk rclk rinc wdataM = (rdata,rempty,wfull) where s_rptr = ptrSync rclk wclk rptr s_wptr = ptrSync wclk rclk wptr - rdata = fifoMem wclk rclk addrSize waddr raddr winc wfull wdata + rdata = fifoMem wclk rclk addrSize wfull raddr + (liftA2 (,) \<$\> (Just \<$\> waddr) \<*\> wdataM) (rempty,raddr,rptr) = 'mealyB'' rclk (ptrCompareT addrSize isEmpty) rptrEmptyInit (s_wptr,rinc) (wfull,waddr,wptr) = 'mealyB'' wclk (ptrCompareT addrSize (isFull addrSize)) - wptrFullInit (s_rptr,winc) + wptrFullInit (s_rptr,isJust \<$\> wdataM) @ == Instantiating a FIFO synchroniser @@ -1521,10 +1586,10 @@ domain and to the FFT clock domain: @ -adcToFFT :: Signal' ClkADC (SFixed 8 8) - -> Signal' ClkADC Bool - -> Signal' ClkFFT Bool - -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool) +adcToFFT + :: Signal' ClkFFT Bool + -> Signal' ClkADC (Maybe (SFixed 8 8)) + -> (Signal' ClkFFT (SFixed 8 8), Signal' ClkFFT Bool, Signal' ClkADC Bool) adcToFFT = fifo d8 clkADC clkFFT @ @@ -1654,7 +1719,7 @@ @topEntity@ has no arguments, you're out of luck for now. If it has multiple arguments, consider bundling them in a tuple. -* __\<*** Exception: \<\\>__ +* __\<*** Exception: \<\\>__ or "blinking cursor" You are using value-recursion, but one of the 'Vec'tor functions that you are using is too /strict/ in one of the recursive arguments. For example: @@ -1818,7 +1883,7 @@ for which the compiler has hard-coded knowledge. For \"easy\" 'Vec'tor literals you should use Template Haskell splices and - the 'v' /meta/-function that as we have seen earlier in this tutorial. + the 'listToVecTH' /meta/-function that as we have seen earlier in this tutorial. * __GADT pattern matching__ diff --git a/src/CLaSH/XException.hs b/src/CLaSH/XException.hs new file mode 100644 --- /dev/null +++ b/src/CLaSH/XException.hs @@ -0,0 +1,320 @@ +{-| +Copyright : (C) 2016, University of Twente +License : BSD2 (see the file LICENSE) +Maintainer : Christiaan Baaij + +'X': An exception for uninitialized values + +>>> show (errorX "undefined" :: Integer, 4 :: Int) +"(*** Exception: X: undefined +CallStack (from HasCallStack): +... +>>> showX (errorX "undefined" :: Integer, 4 :: Int) +"(X,4)" +-} + +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +{-# LANGUAGE Trustworthy #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module CLaSH.XException + ( -- * 'X': An exception for uninitialized values + XException, errorX + -- * Printing 'X' exceptions as \"X\" + , ShowX (..), showsX, printX, showsPrecXWith) +where + +import Control.Exception (Exception, catch, evaluate, throw) +import Data.Complex (Complex) +import Data.Int (Int8,Int16,Int32,Int64) +import Data.Ratio (Ratio) +import Data.Word (Word8,Word16,Word32,Word64) +import GHC.Exts (Char (C#), Double (D#), Float (F#), Int (I#), Word (W#)) +import GHC.Generics +import GHC.Show (appPrec) +import GHC.Stack (HasCallStack, callStack, prettyCallStack) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- | An exception representing an \"uninitialised\" value. +newtype XException = XException String + +instance Show XException where + show (XException s) = s + +instance Exception XException + +-- | Like 'error', but throwing an 'XException' instead of an 'ErrorCall' +-- +-- The 'ShowX' methods print these error-values as \"X\"; instead of error'ing +-- out with an exception. +errorX :: HasCallStack => String -> a +errorX msg = throw (XException ("X: " ++ msg ++ "\n" ++ prettyCallStack callStack)) + +showXWith :: (a -> ShowS) -> a -> ShowS +showXWith f x = + \s -> unsafeDupablePerformIO (catch (f <$> evaluate x <*> pure s) + (\(XException _) -> return ('X': s))) + +-- | Use when you want to create a 'ShowX' instance where: +-- +-- - There is no 'Generic' instance for your data type +-- - The 'Generic' derived ShowX method would traverse into the (hidden) +-- implementation details of your data type, and you just want to show the +-- entire value as \"X\". +-- +-- Can be used like: +-- +-- > data T = ... +-- > +-- > instance Show T where ... +-- > +-- > instance ShowX T where +-- > showsPrecX = showsPrecXWith showsPrec +showsPrecXWith :: (Int -> a -> ShowS) -> Int -> a -> ShowS +showsPrecXWith f n = showXWith (f n) + +-- | Like 'shows', but values that normally throw an 'X' exception are +-- converted to \"X\", instead of error'ing out with an exception. +showsX :: ShowX a => a -> ShowS +showsX = showsPrecX 0 + +-- | Like 'print', but values that normally throw an 'X' exception are +-- converted to \"X\", instead of error'ing out with an exception +printX :: ShowX a => a -> IO () +printX x = putStrLn $ showX x + +-- | Like the 'Show' class, but values that normally throw an 'X' exception are +-- converted to \"X\", instead of error'ing out with an exception. +-- +-- >>> show (errorX "undefined" :: Integer, 4 :: Int) +-- "(*** Exception: X: undefined +-- CallStack (from HasCallStack): +-- ... +-- >>> showX (errorX "undefined" :: Integer, 4 :: Int) +-- "(X,4)" +-- +-- Can be derived using 'GHC.Generics': +-- +-- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} +-- > +-- > import CLaSH.Prelude +-- > import GHC.Generics +-- > +-- > data T = MkTA Int | MkTB Bool +-- > deriving (Show,Generic,ShowX) +class ShowX a where + -- | Like 'showsPrec', but values that normally throw an 'X' exception are + -- converted to \"X\", instead of error'ing out with an exception. + showsPrecX :: Int -> a -> ShowS + + -- | Like 'show', but values that normally throw an 'X' exception are + -- converted to \"X\", instead of error'ing out with an exception. + showX :: a -> String + showX x = showsX x "" + + -- | Like 'showList', but values that normally throw an 'X' exception are + -- converted to \"X\", instead of error'ing out with an exception. + showListX :: [a] -> ShowS + showListX ls s = showListX__ showsX ls s + + default showsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS + showsPrecX = genericShowsPrecX + +showListX__ :: (a -> ShowS) -> [a] -> ShowS +showListX__ showx = showXWith go + where + go [] s = "[]" ++ s + go (x:xs) s = '[' : showx x (showl xs) + where + showl [] = ']':s + showl (y:ys) = ',' : showx y (showl ys) + +data ShowType = Rec -- Record + | Tup -- Tuple + | Pref -- Prefix + | Inf String -- Infix + +genericShowsPrecX :: (Generic a, GShowX (Rep a)) => Int -> a -> ShowS +genericShowsPrecX n = gshowsPrecX Pref n . from + +instance ShowX () +instance (ShowX a, ShowX b) => ShowX (a,b) +instance (ShowX a, ShowX b, ShowX c) => ShowX (a,b,c) +instance (ShowX a, ShowX b, ShowX c, ShowX d) => ShowX (a,b,c,d) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e) => ShowX (a,b,c,d,e) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f) => ShowX (a,b,c,d,e,f) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g) => ShowX (a,b,c,d,e,f,g) + +-- Show is defined up to 15-tuples, but GHC.Generics only has Generic instances +-- up to 7-tuples, hence we need these orphan instances. +deriving instance Generic ((,,,,,,,) a b c d e f g h) +deriving instance Generic ((,,,,,,,,) a b c d e f g h i) +deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j) +deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k) +deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l) +deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m) +deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n) +deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o) + +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h) => ShowX (a,b,c,d,e,f,g,h) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i) => ShowX (a,b,c,d,e,f,g,h,i) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j) + => ShowX (a,b,c,d,e,f,g,h,i,j) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k) + => ShowX (a,b,c,d,e,f,g,h,i,j,k) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l) + => ShowX (a,b,c,d,e,f,g,h,i,j,k,l) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l + ,ShowX m) + => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l + ,ShowX m, ShowX n) + => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n) +instance (ShowX a, ShowX b, ShowX c, ShowX d, ShowX e, ShowX f, ShowX g, ShowX h, ShowX i, ShowX j, ShowX k, ShowX l + ,ShowX m, ShowX n, ShowX o) + => ShowX (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) + +instance {-# OVERLAPPABLE #-} ShowX a => ShowX [a] where + showsPrecX _ = showListX + +instance ShowX Bool + +instance ShowX Double where + showsPrecX = showsPrecXWith showsPrec + +instance (ShowX a, ShowX b) => ShowX (Either a b) + +instance ShowX Float where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Int where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Int8 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Int16 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Int32 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Int64 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Integer where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Word where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Word8 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Word16 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Word32 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX Word64 where + showsPrecX = showsPrecXWith showsPrec + +instance ShowX a => ShowX (Maybe a) + +instance ShowX a => ShowX (Ratio a) where + showsPrecX = showsPrecXWith showsPrecX + +instance ShowX a => ShowX (Complex a) + +instance {-# OVERLAPPING #-} ShowX String where + showsPrecX = showsPrecXWith showsPrec + +class GShowX f where + gshowsPrecX :: ShowType -> Int -> f a -> ShowS + isNullary :: f a -> Bool + isNullary = error "generic showX (isNullary): unnecessary case" + +instance GShowX U1 where + gshowsPrecX _ _ U1 = id + isNullary _ = True + +instance (ShowX c) => GShowX (K1 i c) where + gshowsPrecX _ n (K1 a) = showsPrecX n a + isNullary _ = False + +instance (GShowX a, Constructor c) => GShowX (M1 C c a) where + gshowsPrecX _ n c@(M1 x) = + case fixity of + Prefix -> + showParen (n > appPrec && not (isNullary x)) + ( (if conIsTuple c then id else showString (conName c)) + . (if isNullary x || conIsTuple c then id else showString " ") + . showBraces t (gshowsPrecX t appPrec x)) + Infix _ m -> showParen (n > m) (showBraces t (gshowsPrecX t m x)) + where fixity = conFixity c + t = if conIsRecord c then Rec else + case conIsTuple c of + True -> Tup + False -> case fixity of + Prefix -> Pref + Infix _ _ -> Inf (show (conName c)) + showBraces :: ShowType -> ShowS -> ShowS + showBraces Rec p = showChar '{' . p . showChar '}' + showBraces Tup p = showChar '(' . p . showChar ')' + showBraces Pref p = p + showBraces (Inf _) p = p + + conIsTuple :: C1 c f p -> Bool + conIsTuple y = tupleName (conName y) where + tupleName ('(':',':_) = True + tupleName _ = False + +instance (Selector s, GShowX a) => GShowX (M1 S s a) where + gshowsPrecX t n s@(M1 x) | selName s == "" = gshowsPrecX t n x + | otherwise = showString (selName s) + . showString " = " + . gshowsPrecX t 0 x + isNullary (M1 x) = isNullary x + +instance (GShowX a) => GShowX (M1 D d a) where + gshowsPrecX t = showsPrecXWith go + where go n (M1 x) = gshowsPrecX t n x + +instance (GShowX a, GShowX b) => GShowX (a :+: b) where + gshowsPrecX t n (L1 x) = gshowsPrecX t n x + gshowsPrecX t n (R1 x) = gshowsPrecX t n x + +instance (GShowX a, GShowX b) => GShowX (a :*: b) where + gshowsPrecX t@Rec n (a :*: b) = + gshowsPrecX t n a . showString ", " . gshowsPrecX t n b + gshowsPrecX t@(Inf s) n (a :*: b) = + gshowsPrecX t n a . showString s . gshowsPrecX t n b + gshowsPrecX t@Tup n (a :*: b) = + gshowsPrecX t n a . showChar ',' . gshowsPrecX t n b + gshowsPrecX t@Pref n (a :*: b) = + gshowsPrecX t (n+1) a . showChar ' ' . gshowsPrecX t (n+1) b + + -- If we have a product then it is not a nullary constructor + isNullary _ = False + +-- Unboxed types +instance GShowX UChar where + gshowsPrecX _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' +instance GShowX UDouble where + gshowsPrecX _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" +instance GShowX UFloat where + gshowsPrecX _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' +instance GShowX UInt where + gshowsPrecX _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' +instance GShowX UWord where + gshowsPrecX _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"