kansas-lava 0.2.4 → 0.2.4.2
raw patch · 14 files changed
+93/−45 lines, 14 filesdep ~basedep ~cmdargsdep ~sized-typessetup-changednew-uploader
Dependency ranges changed: base, cmdargs, sized-types
Files
- Language/KansasLava/Fabric.hs +11/−3
- Language/KansasLava/Netlist/Utils.hs +7/−7
- Language/KansasLava/Probes.hs +5/−1
- Language/KansasLava/Protocols/Patch.hs +8/−1
- Language/KansasLava/RTL.hs +19/−4
- Language/KansasLava/Rep/TH.hs +2/−2
- Language/KansasLava/Test.hs +2/−2
- Language/KansasLava/Utils.hs +3/−3
- Language/KansasLava/VHDL.hs +1/−1
- Setup.hs +4/−0
- kansas-lava.cabal +12/−6
- tests/Coerce.hs +2/−2
- tests/Matrix.hs +7/−3
- tests/Others.hs +10/−10
Language/KansasLava/Fabric.hs view
@@ -23,6 +23,7 @@ , runFabricWithDriver ) where +import Control.Applicative import Control.Monad.Fix import Control.Monad hiding (join) import Data.Sized.Ix@@ -94,8 +95,15 @@ instance Functor Fabric where fmap f fab = fab >>= \ a -> return (f a) +instance Applicative Fabric where+ pure x = Fabric $ \ _ -> (x, [], [])+ (Fabric ff) <*> (Fabric fx) = Fabric $ \ ins ->+ let (f, in_names, outs) = ff ins+ (x, in_names', outs') = fx ins+ in (f x, in_names ++ in_names', outs ++ outs')+ instance Monad Fabric where- return a = Fabric $ \ _ -> (a,[],[])+ return = pure (Fabric f) >>= k = Fabric $ \ ins -> let (a,in_names,outs) = f ins (r,in_names',outs') = unFabric (k a) ins@@ -400,12 +408,12 @@ data X (ExternalStdLogicVector ix) = XExternalStdLogicVector (ExternalStdLogicVector ix) optX (Just b) = XExternalStdLogicVector $ b- optX Nothing = XExternalStdLogicVector + optX Nothing = XExternalStdLogicVector $ ExternalStdLogicVector $ RepValue $ replicate (size (error "Rep/ExternalStdLogicVector" :: ix)) Nothing unX (XExternalStdLogicVector a) = return a- + repType _ = V (size (error "Rep/ExternalStdLogicVector" :: ix)) toRep (XExternalStdLogicVector (ExternalStdLogicVector a)) = a fromRep a = XExternalStdLogicVector (ExternalStdLogicVector a)
Language/KansasLava/Netlist/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -- | This module contains a number of utility functions useful for converting -- Lava circuits to the Netlist AST. module Language.KansasLava.Netlist.Utils@@ -42,7 +42,7 @@ -- | Given a type and a value, convert it to a netlist Expr. toTypedExpr :: Type -> v -> Expr -instance (Integral a) => ToTypedExpr (Driver a) where+instance (Integral a, Show a) => ToTypedExpr (Driver a) where -- From a std_logic* into a typed Expr toTypedExpr ty (Lit n) = toTypedExpr ty n toTypedExpr ty (Generic n) = toTypedExpr ty n@@ -82,11 +82,11 @@ instance ToTypedExpr RepValue where -- From a literal into a typed Expr -- NOTE: We use Integer here as a natural, and assume overflow- toTypedExpr (S n) r = ExprFunCall "to_signed" + toTypedExpr (S n) r = ExprFunCall "to_signed" [ ExprLit Nothing $ ExprNum $ fromRepToInteger r , ExprLit Nothing $ ExprNum $ fromIntegral n ]- toTypedExpr (U n) r = ExprFunCall "to_unsigned" + toTypedExpr (U n) r = ExprFunCall "to_unsigned" [ ExprLit Nothing $ ExprNum $ fromRepToInteger r , ExprLit Nothing $ ExprNum $ fromIntegral n ]@@ -105,7 +105,7 @@ toStdLogicEleExpr :: Int -> Type -> v -> Expr toStdLogicEleExpr = error "toStdLogicEleExpr" -instance (Integral a) => ToStdLogicExpr (Driver a) where+instance (Integral a, Show a) => ToStdLogicExpr (Driver a) where -- From a std_logic* (because you are a driver) into a std_logic. toStdLogicExpr ty _ | typeWidth ty == 0 = ExprVar "\"\""@@ -167,7 +167,7 @@ -- | Given a type and a signal, generate the appropriate Netlist Expr. toIntegerExpr :: Type -> v -> Expr -instance (Integral i) => ToIntegerExpr (Driver i) where+instance (Integral i, Show i) => ToIntegerExpr (Driver i) where -- can assume a small (shift-by) number toIntegerExpr _ (Lit v) = ExprLit Nothing $ ExprNum (fromRepToInteger v) toIntegerExpr GenericTy other = toTypedExpr GenericTy other -- HACK@@ -247,7 +247,7 @@ isHigh d = ExprBinary Equals d (ExprLit Nothing (ExprBit T)) -- | Convert a driver to an Expr to be used as a memory address.-toMemIndex :: Integral t => Type -> Driver t -> Expr+toMemIndex :: (Integral t, Show t) => Type -> Driver t -> Expr toMemIndex ty _ | typeWidth ty == 0 = ExprLit Nothing (ExprNum 0) toMemIndex _ (Lit n) = ExprLit Nothing $ ExprNum $ fromRepToInteger n toMemIndex ty dr = to_integer $ unsigned $ toStdLogicExpr ty dr
Language/KansasLava/Probes.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, RankNTypes, ExistentialQuantification, ScopedTypeVariables, UndecidableInstances, TypeSynonymInstances, TypeFamilies, GADTs #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}+{-# LANGUAGE ScopedTypeVariables, AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances, TypeSynonymInstances #-}+{-# LANGUAGE ExistentialQuantification, TypeFamilies, GADTs #-} -- | Probes log the shallow-embedding signals of a Lava circuit in the -- | deep embedding, so that the results can be observed post-mortem. module Language.KansasLava.Probes (
Language/KansasLava/Protocols/Patch.hs view
@@ -1,4 +1,11 @@-{-# LANGUAGE DoRec, ScopedTypeVariables, FlexibleContexts, TypeFamilies, ParallelListComp, TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes, UndecidableInstances, TypeOperators, NoMonomorphismRestriction #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances, TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}+{-# LANGUAGE TypeFamilies, GADTs #-}+{-# LANGUAGE ParallelListComp, TypeOperators #-} module Language.KansasLava.Protocols.Patch -- (Patch, bus, ($$), -- emptyP,forwardP, backwardP,dupP,zipPatch,
Language/KansasLava/RTL.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE RankNTypes, GADTs, ExistentialQuantification,- ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-}-+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeFamilies, ExistentialQuantification, GADTs #-} -- | The RTL module provides a small DSL that's useful for control-oriented -- stateful -- computations. module Language.KansasLava.RTL ( RTL(..), -- not abstract@@ -19,9 +20,11 @@ import Language.KansasLava.Utils import Language.KansasLava.Probes import Data.Sized.Matrix+import Control.Applicative import Control.Monad.ST import Data.STRef import Data.List as L+import Control.Monad.ST.Unsafe (unsafeInterleaveST) --import Debug.Trace @@ -84,8 +87,20 @@ -- everything except ($) bids tighter infixr 0 := +instance Functor (RTL s c) where+ fmap f m = RTL $ \ c u -> do+ (x, us) <- unRTL m c u+ return (f x, us)++instance Applicative (RTL s c) where+ pure x = RTL $ \ _ _ -> return (x, [])+ mf <*> mx = RTL $ \ c u -> do+ (f, us1) <- unRTL mf c u+ (x, us2) <- unRTL mx c u+ return (f x, us1 ++ us2)+ instance Monad (RTL s c) where- return a = RTL $ \ _ _ -> return (a,[])+ return = pure m >>= k = RTL $ \ c u -> do (r1,f1) <- unRTL m c u (r2,f2) <- unRTL (k r1) c u return (r2,f1 ++ f2)
Language/KansasLava/Rep/TH.hs view
@@ -17,7 +17,7 @@ sequence [ instanceD (return []) (appT (conT ''Rep) (conT tyName))- [ tySynInstD ''W [conT tyName] (conT (mkName xSize))+ [ tySynInstD ''W (tySynEqn [conT tyName] (conT (mkName xSize))) , dataInstD (return []) ''X [conT tyName] [ normalC xConsName@@ -66,7 +66,7 @@ sequence [ instanceD (return []) (appT (conT ''Rep) (conT tyName))- [ tySynInstD ''W [conT tyName] (conT (mkName xSize))+ [ tySynInstD ''W (tySynEqn [conT tyName] (conT (mkName xSize))) , dataInstD (return []) ''X [conT tyName] [ normalC xConsName
Language/KansasLava/Test.hs view
@@ -802,10 +802,10 @@ readPreludeFile fname = do ks <- getEnv "KANSAS_LAVA_ROOT" Strict.readFile (ks </> fname)- `Prelude.catch` \_ -> do+ `E.catch` \ (_ :: IOException) -> do path <- getDataFileName fname Strict.readFile path- `Prelude.catch` \_ -> do+ `E.catch` \ (_ :: IOException) -> do putStrLn "Set the KANSAS_LAVA_ROOT environment variable" putStrLn "to point to the root of the KsLava source directory." exitFailure
Language/KansasLava/Utils.hs view
@@ -61,7 +61,7 @@ xor2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool xor2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of (Just a',Just b') -> optX $ Just (a' /= b')- _ -> optX $ Nothing ) "or2"+ _ -> optX $ Nothing ) "xor2" s1 s2 @@ -427,9 +427,9 @@ --------------------------------------------------------------------- -- These varients of succ/pred can handle bounded values and do proper looping.-loopingIncS :: (Bounded a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a+loopingIncS :: (Bounded a, Eq a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a loopingIncS a = mux (a .==. maxBound) (a + 1, pureS 0) -loopingDecS :: (Bounded a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a+loopingDecS :: (Bounded a, Eq a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a loopingDecS a = mux (a .==. 0) (a - 1, pureS maxBound)
Language/KansasLava/VHDL.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE ParallelListComp #-} -- | This module converts a Lava circuit to a synthesizable VHDL netlist.-module Language.KansasLava.VHDL(writeVhdlCircuit, writeVhdlPrelude, mkTestbench) where+module Language.KansasLava.VHDL(netlistCircuit, writeVhdlCircuit, writeVhdlPrelude, mkTestbench) where import Data.List(mapAccumL)
Setup.hs view
@@ -1,2 +1,6 @@+module Main (main) where+ import Distribution.Simple++main :: IO () main = defaultMain
kansas-lava.cabal view
@@ -1,5 +1,5 @@ Name: kansas-lava-Version: 0.2.4+Version: 0.2.4.2 Synopsis: Kansas Lava is a hardware simulator and VHDL generator. Description: @@ -43,13 +43,13 @@ base >= 4 && < 5, dotgen >= 0.4.1, containers,- sized-types >= 0.3.4,+ sized-types >= 0.3.4 && < 0.4, data-default, random, strict, filepath, directory,- cmdargs==0.8,+ cmdargs, process, netlist >= 0.3.1, netlist-to-vhdl >= 0.3.1,@@ -109,7 +109,7 @@ strict, filepath, directory,- cmdargs==0.8,+ cmdargs, process, netlist >= 0.3.1, netlist-to-vhdl >= 0.3.1,@@ -141,7 +141,7 @@ strict, filepath, directory,- cmdargs==0.8,+ cmdargs, process, netlist >= 0.3.1, netlist-to-vhdl >= 0.3.1,@@ -170,7 +170,7 @@ strict, filepath, directory,- cmdargs==0.8,+ cmdargs, process, netlist >= 0.3.1, netlist-to-vhdl >= 0.3.1,@@ -189,3 +189,9 @@ source-repository head type: git location: git://github.com/ku-fpg/kansas-lava.git++source-repository this+ type: git+ location: git://github.com/ku-fpg/kansas-lava.git+ branch: kansas-lava-0.2.4+ tag: 0.2.4.2
tests/Coerce.hs view
@@ -14,7 +14,7 @@ tests :: TestSeq -> IO () tests test = do - let t1 :: (Bounded w2, Integral w2, Integral w1, Rep w2, Rep w1, Size (W w1), Size (W w2)) =>+ let t1 :: (Bounded w2, Integral w2, Integral w1, Rep w2, Show w2, Rep w1, Size (W w1), Size (W w2)) => String -> Witness w2 -> List w1 -> IO () t1 str witness arb = testUnsigned test str witness arb@@ -59,7 +59,7 @@ t1 "X5_X4" (Witness :: Witness X5) ((allCases :: List X4)) t1 "X5_X5" (Witness :: Witness X5) ((allCases :: List X5)) - let t2 :: (Bounded w1, Bounded w2, Integral w2, Integral w1, Rep w2, Rep w1, Size (W w1), Size (W w2)) =>+ let t2 :: (Bounded w1, Bounded w2, Integral w2, Integral w1, Show w2, Rep w2, Rep w1, Size (W w1), Size (W w2)) => String -> Witness w2 -> List w1 -> IO () t2 str witness arb = testSigned test str witness arb
tests/Matrix.hs view
@@ -20,7 +20,9 @@ Size w1, Rep w2, Rep w1,+ Eq w2, Num w2,+ Show w2, Integral w1) => String -> List (M.Matrix w1 w2) -> IO () t1 str arb = testMatrix1 test str arb @@ -32,7 +34,9 @@ Size w1, Rep w2, Rep w1,+ Eq w2, Num w2,+ Show w2, Integral w1) => String -> List (M.Matrix w1 w2) -> IO () t2 str arb = testMatrix2 test str arb @@ -68,7 +72,7 @@ outStdLogicVector "o0" o0 res = toS [ sum $ M.toList m | m <- ms ] :: Seq w2 - test ("matrix/1/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) + test ("matrix/1/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) testMatrix2 :: forall w1 w2 . ( Integral w1, Size w1, Eq w1, Rep w1@@ -91,7 +95,7 @@ outStdLogicVector "o0" o0 res = toS [ m | m <- ms ] :: Seq (M.Matrix w1 w2) - test ("matrix/2/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) + test ("matrix/2/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) testMatrix3 :: forall w1 .@@ -115,4 +119,4 @@ outStdLogicVector "o0" o0 res = toS [ m | m <- ms ] :: Seq (Enabled w1) - test ("matrix/3/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) + test ("matrix/3/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)
tests/Others.hs view
@@ -18,7 +18,7 @@ tests :: TestSeq -> IO () tests test = do -- Just the Num Stuff- let t1 :: (Fractional a, Ord a, Rep a, Size (W a)) => String -> [a] -> IO ()+ let t1 :: (Fractional a, Ord a, Show a, Rep a, Size (W a)) => String -> [a] -> IO () t1 str arb = testOpsFractional test str arb -- With Sampled, use -- * powers of two scale, larger than 1@@ -31,12 +31,12 @@ t1 "Sampled/X128xX16"(finiteCases 100 ::[Sampled X128 X16]) -- Just the Bits Stuff- let t2 :: (Ord a, Bits a, Rep a, Size (W a)) => String -> List a -> IO ()+ let t2 :: (Ord a, Bits a, Show a, Rep a, Size (W a)) => String -> List a -> IO () t2 str arb = testOpsBits test str arb -- tests Bits, inc the shifts- let t2' :: (Ord a, Bits a, Rep a, Size (W a), Integral (W a), Rep (W a), Size (W (W a))) => String -> List a -> IO ()+ let t2' :: (Ord a, Bits a, Show a, Rep a, Size (W a), Integral (W a), Rep (W a), Size (W (W a))) => String -> List a -> IO () t2' str arb = testOpsBits2 test str arb t2' "U1" (allCases :: List U1)@@ -241,7 +241,7 @@ testOpsNum :: forall w .- (Ord w, Rep w, Num w, Size (W w)) => TestSeq -> String -> List w -> IO ()+ (Ord w, Rep w, Num w, Show w, Size (W w)) => TestSeq -> String -> List w -> IO () testOpsNum test tyName ws = do testOpsOrd test tyName ws @@ -269,7 +269,7 @@ return () testOpsFractional :: forall w .- (Ord w, Rep w, Fractional w, Size (W w)) => TestSeq -> String -> [w] -> IO ()+ (Ord w, Rep w, Show w, Fractional w, Size (W w)) => TestSeq -> String -> [w] -> IO () testOpsFractional test tyName ws = do testOpsNum test tyName ws @@ -290,7 +290,7 @@ ---------------------------------------------------------------------------------------- testOpsBits :: forall w .- (Ord w, Rep w, Bits w, Size (W w)) => TestSeq -> String -> List w -> IO ()+ (Ord w, Rep w, Show w, Bits w, Size (W w)) => TestSeq -> String -> List w -> IO () testOpsBits test tyName ws = do testOpsNum test tyName ws @@ -317,7 +317,7 @@ testOpsBits2 :: forall w .- (Ord w, Rep w, Bits w, Size (W w), Integral (W w), Rep (W w), Size (W (W w))) => TestSeq -> String -> List w -> IO ()+ (Ord w, Rep w, Show w, Bits w, Size (W w), Integral (W w), Rep (W w), Size (W (W w))) => TestSeq -> String -> List w -> IO () testOpsBits2 test tyName ws = do testOpsBits test tyName ws @@ -344,9 +344,9 @@ ] else [] ] - let ws2 :: List (w,W w) + let ws2 :: List (w,W w) ws2 = zip ws (cycle [0..maxBound])- + sequence_ [ testBinOp test (name ++ "/" ++ tyName) opr@@ -354,7 +354,7 @@ ws2 | TestIx name opr lavaOp <- [ TestIx "testABit" (\ a b -> testBit a (fromIntegral b)) (testABit)- ] + ] ] return ()