kansas-lava (empty) → 0.2.4
raw patch · 49 files changed
+10287/−0 lines, 49 filesdep +basedep +bytestringdep +cmdargssetup-changed
Dependencies added: base, bytestring, cmdargs, containers, data-default, data-reify, directory, dotgen, filepath, netlist, netlist-to-vhdl, process, random, sized-types, strict, template-haskell
Files
- LICENSE +25/−0
- Language/KansasLava.hs +68/−0
- Language/KansasLava/DOT.hs +101/−0
- Language/KansasLava/Dynamic.hs +28/−0
- Language/KansasLava/Entity.hs +61/−0
- Language/KansasLava/Fabric.hs +412/−0
- Language/KansasLava/Internal.hs +65/−0
- Language/KansasLava/Netlist/Decl.hs +75/−0
- Language/KansasLava/Netlist/Inst.hs +930/−0
- Language/KansasLava/Netlist/Utils.hs +392/−0
- Language/KansasLava/Optimization.hs +255/−0
- Language/KansasLava/Probes.hs +96/−0
- Language/KansasLava/Protocols.hs +16/−0
- Language/KansasLava/Protocols/AckBox.hs +203/−0
- Language/KansasLava/Protocols/Enabled.hs +68/−0
- Language/KansasLava/Protocols/Memory.hs +153/−0
- Language/KansasLava/Protocols/Patch.hs +824/−0
- Language/KansasLava/Protocols/ReadyBox.hs +155/−0
- Language/KansasLava/Protocols/Types.hs +82/−0
- Language/KansasLava/RTL.hs +188/−0
- Language/KansasLava/Rep.hs +343/−0
- Language/KansasLava/Rep/Class.hs +177/−0
- Language/KansasLava/Rep/TH.hs +129/−0
- Language/KansasLava/Signal.hs +443/−0
- Language/KansasLava/Stream.hs +79/−0
- Language/KansasLava/Test.hs +836/−0
- Language/KansasLava/Types.hs +694/−0
- Language/KansasLava/Utils.hs +435/−0
- Language/KansasLava/VCD.hs +324/−0
- Language/KansasLava/VCD/EventList.hs +154/−0
- Language/KansasLava/VHDL.hs +323/−0
- Prelude/HTML/footer.inc +2/−0
- Prelude/HTML/header.inc +63/−0
- Prelude/HTML/mid.inc +2/−0
- Prelude/VHDL/Lava.vhd +418/−0
- Prelude/VHDL/Modelsim.vhd +189/−0
- README +16/−0
- Setup.hs +2/−0
- kansas-lava.cabal +191/−0
- tests/Coerce.hs +200/−0
- tests/GenReport.hs +13/−0
- tests/Main.hs +29/−0
- tests/Makefile +31/−0
- tests/Matrix.hs +118/−0
- tests/Memory.hs +206/−0
- tests/Others.hs +429/−0
- tests/Protocols.hs +158/−0
- tests/Regression.hs +42/−0
- tools/TBF2VCD.hs +44/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009-2011 The University of Kansas+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Language/KansasLava.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies, FlexibleInstances, ScopedTypeVariables, GADTs, FlexibleContexts #-}+-- | A top-level module that re-exports the relevent parts of the library's internal modules.+module Language.KansasLava (+ -- * Basic types in Kansas Lava+ module Language.KansasLava.Types,+ + -- * Generating KLEG netlists+ Fabric,+ reifyFabric,+ inStdLogic, inStdLogicVector,inGeneric,+ outStdLogic, outStdLogicVector,+ theClk, theRst, theClkEn,++ -- * The CSeq and Seq types+ Signal, Seq, + toS, toS', undefinedS, fromS, takeS,+ pureS, witnessS,+ commentS,+ pack, unpack,+ packMatrix, unpackMatrix,+ register, registers, delay, delays,+ + -- * Rendering KLEG as a Graph+ writeDotCircuit,++ -- * Optimizing KLEG+ OptimizationOpts(..),+ optimizeCircuit,+ + -- * Outputing VHDL+ writeVhdlCircuit,+ writeVhdlPrelude,++ -- * RTL sub-DSL+ module Language.KansasLava.RTL,++ -- * Probes+ module Language.KansasLava.Probes,++ -- * Protocols+ module Language.KansasLava.Protocols,++ -- * Rep+ module Language.KansasLava.Rep,++ -- * Kansas Lava User-level Utils+ module Language.KansasLava.Utils,++ -- * Version Change Dump+ VCD,+ writeVCDFile,+ readVCDFile+ ) where++import Language.KansasLava.DOT+import Language.KansasLava.Fabric+import Language.KansasLava.Optimization+import Language.KansasLava.Probes+import Language.KansasLava.Protocols+import Language.KansasLava.Rep+import Language.KansasLava.RTL+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Utils+import Language.KansasLava.VCD+import Language.KansasLava.VHDL++
+ Language/KansasLava/DOT.hs view
@@ -0,0 +1,101 @@+-- | Convert a reified Lava 'KLEG' into a graphical Graphviz format.+module Language.KansasLava.DOT (writeDotCircuit) where++import Language.KansasLava.Types++import Data.Reify.Graph(Unique)+import Text.Dot(Dot,NodeId,showDot, attribute, node,edge')+import Data.List(intercalate)+import Data.Maybe(fromMaybe)++-- | The 'writeDotCircuit' function converts a Lava circuit into a graphviz output.+writeDotCircuit :: FilePath -- ^ Name of output dot file, can be relative or absolute path.+ -> KLEG -- ^ The reified Lava circuit.+ -> IO ()+writeDotCircuit filename (KLEG nodes circInputs circOutputs) = do++ let showP :: (String,Type) -> String+ showP (v,ty) = "<" ++ v ++ ">" ++ v ++ "::" ++ show ty++ join = intercalate "|"++ mkLabel :: String -> [(String,Type)] -> [(String,Type)] -> String+ mkLabel nm ins outs =+ concatMap addSpecial nm ++ "|{{"+ ++ join (map showP ins) ++ "}|{"+ ++ join (map showP outs) ++ "}}"++ -- TODO: insert types+ -- mkPLabel pname nm ins outs = "{" ++ (concatMap addSpecial $ show nm) ++ "|" ++ join pname ++ "}|{{"+ -- ++ join (map showP ins) ++ "}|{"+ -- ++ join (map showP outs) ++ "}}"++ writeFile filename $ showDot $ do+ attribute ("rankdir","LR")++ input_bar <- node [ ("label","INPUTS|{{" ++ join [ showP (show o,i) | (o,i) <- circInputs] ++ "}}")+ , ("shape","record")+ , ("style","filled")+ ]+++ nds <- sequence [ do nd <- node [ ("label",mkLabel (show nm)+ [ (v,ty) |(v,ty,_) <- ins ]+ [ (v,ty) | (v,ty) <- outs] )+ , ("shape","record")+ , ("style","rounded")+ ]+ return (n,nd)+ | (n,Entity nm outs ins) <- nodes ]+++ output_bar <- node [ ("label","OUTPUTS|{{" ++ join [ showP (show i,ty) | (i,ty,_) <- circOutputs ] ++ "}}")+ , ("shape","record")+ , ("style","filled")+ ]++ let findNd n = fromMaybe (error $ "strange port: " ++ show (n,nds)) (lookup n nds)++ let drawEdge :: Driver Unique -> NodeId -> String -> Dot ()+ drawEdge (Port nm' n') n v = edge' (findNd n') (Just (show nm' ++ ":e")) n (Just (show v ++ ":w")) []+ drawEdge (Pad v') n v+ | v' `elem` map fst circInputs+ = edge' input_bar (Just (show (show v') ++ ":e")) n (Just (show v ++ ":w")) []+ | otherwise = do nd' <- node [ ("label",show v')]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+ drawEdge (Lit i) n v = do nd' <- node [("label",show i),("shape","none")]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+ drawEdge (Generic i) n v = do nd' <- node [("label",show i),("shape","none")]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+ drawEdge (Error e) n v = do nd' <- node [("label",show e),("shape","none")]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+ drawEdge (ClkDom nm) n v = do nd' <- node [("label",show nm),("shape","none")]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+ drawEdge (Lits ls) n v = do let label = intercalate "," $ map show ls+ nd' <- node [("label",label),("shape","none")]+ edge' nd' Nothing n (Just (show v ++ ":w")) []+++ -- Draw edges to the outputs+ sequence_ [ drawEdge dr output_bar (show v)+ | (v,_,dr) <- circOutputs+ ]++ -- Draw edges between nodes+ sequence_ [ drawEdge dr (findNd n) v+ | (n,Entity _ _ ins) <- nodes+ , (v,_,dr) <- ins+ ]++ return ()++ return () -- for chaining purposes++++-- addSpecial '>' = ['\\','>']+addSpecial :: Char -> String+addSpecial '>' = ">";+addSpecial '<' = "<";+addSpecial c = [c]+
+ Language/KansasLava/Dynamic.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies #-}+-- | This module provides some basic support for co-opting an identity entity block as a box+-- containing some 'Dynamic' data. Any optimization pass+-- will assume these blocks are identities, and perhaps remove them.++module Language.KansasLava.Dynamic where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types++import Data.Dynamic++-- | We use identity "black boxes" as arbitary tags in the syntax, for extentablity.++addDynamic :: (sig ~ Signal i, Rep a) => Dynamic -> sig a -> sig a+addDynamic dyn = idS (BlackBox (Box dyn))++-- | Get any chain of (deep) black boxes on this signal.+getDynamics :: (sig ~ Signal i, Rep a) => sig a -> [Dynamic]+getDynamics sig = find (unD $ deepS sig)+ where+ find :: Driver E -> [Dynamic]+ find (Port _ (E (Entity (BlackBox (Box bb)) _ ins))) =+ bb : case ins of+ [(_,_,i)] -> find i+ _ -> error "getDynamics: no inputs"+ find _ = []
+ Language/KansasLava/Entity.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ExistentialQuantification, TypeFamilies, ParallelListComp, ScopedTypeVariables+ #-}+-- | This module contains convenience functions for building deep embedding entities.+module Language.KansasLava.Entity where++import Language.KansasLava.Rep+import Language.KansasLava.Types++-- | A zero-input Entity.+entity0 :: forall o . (Rep o) => Id -> D o+entity0 nm = D $ Port "o0" $ E $+ Entity nm [("o0",oTy)]+ []+ where oTy = repType (Witness :: Witness o)++-- | A one-input Entity+entity1 :: forall a o . (Rep a, Rep o) => Id -> D a -> D o+entity1 nm (D w1) = D $ Port "o0" $ E $+ Entity nm [("o0",oTy)]+ [(inp,ty,val) | inp <- ["i0","i1"]+ | ty <- [aTy]+ | val <- [w1]+ ]+ where aTy = repType (Witness :: Witness a)+ oTy = repType (Witness :: Witness o)++-- | A two-input entity.+entity2 :: forall a b o . (Rep a, Rep b, Rep o) => Id -> D a -> D b -> D o+entity2 nm (D w1) (D w2) = D $ Port "o0" $ E $+ Entity nm [("o0",oTy)]+ [(inp,ty,val) | inp <- ["i0","i1"]+ | ty <- [aTy,bTy]+ | val <- [w1,w2]+ ]+ where aTy = repType (Witness :: Witness a)+ bTy = repType (Witness :: Witness b)+ oTy = repType (Witness :: Witness o)++-- | A three-input entity.+entity3 :: forall a b c o . (Rep a, Rep b, Rep c, Rep o) => Id -> D a -> D b -> D c -> D o+entity3 nm (D w1) (D w2) (D w3) = D $ Port "o0" $ E $+ Entity nm [("o0",oTy)]+ [(inp,ty,val) | inp <- ["i0","i1","i2"]+ | ty <- [aTy,bTy,cTy]+ | val <- [w1,w2,w3]+ ]+ where aTy = repType (Witness :: Witness a)+ bTy = repType (Witness :: Witness b)+ cTy = repType (Witness :: Witness c)+ oTy = repType (Witness :: Witness o)++-- | An n-ary entity, with all of the inputs having the same type, passed in as a list.+entityN :: forall a o . (Rep a, Rep o) => Id -> [D a] -> D o+entityN nm ds = D $ Port "o0" $ E $+ Entity nm [("o0",oTy)]+ [(inp,ty,val) | inp <- ['i':show (n::Int) | n <- [0..]]+ | ty <- repeat aTy+ | val <- [w | D w <- ds]+ ]+ where aTy = repType (Witness :: Witness a)+ oTy = repType (Witness :: Witness o)
+ Language/KansasLava/Fabric.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE ExistentialQuantification, TypeFamilies,+ ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances,+ FlexibleContexts, UndecidableInstances, GADTs #-}+++-- | The Fabric module is used for generating a top-level VHDL entity for a Lava+-- circuit, with inputs and outputs.+module Language.KansasLava.Fabric+ ( Fabric(..)+ , Pad(..)+ , runFabric+ , inStdLogic+ , inStdLogicVector+ , inGeneric+ , outStdLogic+ , outStdLogicVector+ , padStdLogicType+ , theClk+ , theRst+ , theClkEn+ , reifyFabric+ , runFabricWithResult+ , runFabricWithDriver+ ) where++import Control.Monad.Fix+import Control.Monad hiding (join)+import Data.Sized.Ix+import Data.List as L+import Data.Reify+import qualified Data.Set as Set+import Data.Set(Set)+import qualified Data.Map as Map+import Data.Map(Map)+import Data.Ord(comparing)++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Utils++-- The '_' will disappear soon from these names.+-- | A Pad represents the type of a top-level input/output port.+data Pad = StdLogic (Seq Bool)+ | forall a x . (Size (W a), Show a, Rep a)+ => StdLogicVector (Seq a)+-- | TypedPad (...)+ | GenericPad Integer+ | TheClk+ | TheRst+ | TheClkEn++-- | Get the type of a pad.+padStdLogicType :: Pad -> StdLogicType+padStdLogicType (StdLogic _) = SL+padStdLogicType (StdLogicVector s) = SLV $ size (untype s)+ where untype :: (Size (W a)) => Seq a -> W a+ untype = error "untype"+padStdLogicType (GenericPad _) = G+padStdLogicType (TheClk) = SL+padStdLogicType (TheRst) = SL+padStdLogicType (TheClkEn) = SL++instance Show Pad where+ show (StdLogic sq) = "StdLogic " ++ show sq+ show (StdLogicVector sq) = "StdLogicVector " ++ show sq+ show (GenericPad i) = "Generic " ++ show i+ show (TheClk) = "Clk"+ show (TheRst) = "Rst"+ show (TheClkEn) = "ClkEn"++ -- TODO: the 2D Array++{- | The 'Fabric' structure, which is also a monad.++> fabric_example :: Fabric ()+> fabric_example = do+> i0 <- inStdLogic "i0"+> i1 <- inStdLogic "i1"+> let (c,s) = halfAdder i0 i1+> outStdLogic "carry" c+> outStdLogic "sum" s+> where+> halfAdder :: Seq Bool -> Seq Bool -> (Seq Bool,Seq Bool)+> halfAdder a b = (carry,sum_)+> where carry = and2 a b+> sum_ = xor2 a b++-}+-- | A Fabric consists of a list of input ports, and yields a list of output+-- ports and generics.+data Fabric a = Fabric { unFabric :: [(String,Pad)] -> (a,[(String,Pad)],[(String,Pad)]) }++instance Functor Fabric where+ fmap f fab = fab >>= \ a -> return (f a)++instance Monad Fabric where+ return a = Fabric $ \ _ -> (a,[],[])+ (Fabric f) >>= k = Fabric $ \ ins -> let+ (a,in_names,outs) = f ins+ (r,in_names',outs') = unFabric (k a) ins+ in (r,in_names ++ in_names',outs ++ outs')++instance MonadFix Fabric where+ mfix f = Fabric $ \ env -> let (a,in_names,outs) = unFabric (f a) env+ in (a,in_names,outs)+++-- | Generate a named input port.+input :: String -> Pad -> Fabric Pad+input nm deepPad = Fabric $ \ ins ->+ let p = case lookup nm ins of+ Just v -> v+ _ -> error $ "input internal error finding : " ++ show nm+ in (p,[(nm,deepPad)],[])++-- | Generate a named output port.+output :: String -> Pad -> Fabric ()+output nm pad = Fabric $ \ _ins -> ((),[],[(nm,pad)])++-- | Generate a named std_logic input port.+inStdLogic :: (Rep a, Show a, W a ~ X1) => String -> Fabric (Seq a)+inStdLogic nm = do+ pad <- input nm (StdLogic $ mkDeepS $ D $ Pad nm)+ return $ case pad of+ StdLogic sq -> bitwise sq+ _ -> error "internal type error in inStdLogic"++-- | Generate a named generic.+inGeneric :: String -> Fabric Integer+inGeneric nm = do+ pad <- input nm (GenericPad $ error "Fix Generic")+ return $ case pad of+ GenericPad g -> g+ _ -> error "internal type error in inGeneric"++-- | Generate a named std_logic_vector port input.+inStdLogicVector :: forall a . (Rep a, Show a, Size (W a)) => String -> Fabric (Seq a)+inStdLogicVector nm = do+ let seq' = mkDeepS $ D $ Pad nm :: Seq (ExternalStdLogicVector (W a))+ pad <- input nm (StdLogicVector seq')+ return $ case pad of+ -- This unsigned is hack, but the sizes should always match.+ StdLogicVector sq -> case toStdLogicType ty of+ SLV _ -> unsafeId sq+ G -> error "inStdLogicVector type mismatch: requiring StdLogicVector, found Generic"+ SL -> unsafeId sq+ SLVA _ _ -> unsafeId sq+ _ -> error "internal type error in inStdLogic"+ where+ ty = repType (Witness :: Witness a)++-- | theClk gives the external name for the clock.+theClk :: String -> Fabric ()+theClk nm = input nm TheClk >> return ()++-- | theRst gives the external name for the reset signal [default = low].+theRst :: String -> Fabric ()+theRst nm = input nm TheRst >> return ()++-- | theClkEn gives the external name for the clock enable signal [default = high].+theClkEn :: String -> Fabric ()+theClkEn nm = input nm TheClkEn >> return ()++-------------------------------------------------------------------------------++-- | Generate a named std_logic output port, given a Lava circuit.+outStdLogic ::+ (Rep a, Show a, W a ~ X1) => String -> Seq a -> Fabric ()+outStdLogic nm seq_bool = output nm (StdLogic (bitwise seq_bool))++-- | Generate a named std_logic_vector output port, given a Lava circuit.+outStdLogicVector+ :: forall a .+ (Rep a, Show a, Size (W a)) => String -> Seq a -> Fabric ()+outStdLogicVector nm sq =+ case toStdLogicType (typeOfS sq) of+ G -> error "outStdLogicVector type mismatch: requiring StdLogicVector, found Generic"+ _ -> output nm $ StdLogicVector+ $ (bitwise sq :: Seq (ExternalStdLogicVector (W a)))++-------------------------------------------------------------------------------++-- | Reify a fabric, returning the output ports and the result of the Fabric monad.+runFabric :: Fabric a -> [(String,Pad)] -> (a,[(String,Pad)])+runFabric (Fabric f) args = (a,result)+ where (a,_arg_types,result) = f args++-- | 'runFabric' runs a Fabric a with arguments, and gives a value result.+-- must have no (monadic) outputs.+runFabricWithResult :: Fabric a -> [(String,Pad)] -> a+runFabricWithResult (Fabric f) args = a+ where (a,_arg_types,[]) = f args++-- | 'runFabricWithDriver' runs a Fabric () using a driver Fabric.+runFabricWithDriver :: Fabric () -> Fabric a -> a+runFabricWithDriver (Fabric f) (Fabric g) = a+ where ((),_,f_result) = f g_result+ (a,_,g_result) = g f_result++-------------------------------------------------------------------------------++-- | 'reifyFabric' does reification of a 'Fabric ()' into a 'KLEG'.+reifyFabric :: Fabric () -> IO KLEG+reifyFabric (Fabric circuit) = do+ -- This is knot-tied with the output from the circuit execution+ let (_,ins0,outs0) = circuit ins0++ let mkU :: forall a . (Rep a) => Seq a -> Type+ mkU _ = case toStdLogicType ty of+ G -> error $ "reifyFabric, outputing a non stdlogic[vector]: " ++ show ty+ SLV {} -> ty+ _ -> V $ typeWidth ty+ where+ ty = repType (Witness :: Witness a)++ let top_outs = [ (nm, B, unD $ deepS s) | (nm,StdLogic s) <- outs0 ] +++ [ (nm, mkU s, unD $ deepS s) | (nm,StdLogicVector s) <- outs0 ]++ let o = Port "top"+ $ E+ $ Entity (Prim "top") []+ top_outs++ -- Get the graph, and associate the output drivers for the graph with+ -- output pad names.+ (gr, outpads) <- case o of+ Port _ o' -> do+ (Graph gr out) <- reifyGraph o'+ let gr' = [ (nid,nd) | (nid,nd) <- gr+ , nid /= out+ ]+ case lookup out gr of+ Just (Entity (Prim "top") _ ins) ->+ return (gr',[(nm,ity, driver)+ | (nm,ity,driver) <- ins+ ])+ _ -> error $ "reifyFabric: " ++ show o+ v -> fail $ "reifyGraph failed in reifyFabric" ++ show v++ let ins0' = clk' ++ ins0++ -- only clock has a default always connecteda; this may check for clk somewhere else.+ clk' = if null [ () | (_,TheClk) <- ins0 ] then [("clk",TheClk)] else []++ clk_name = head $ [ Pad nm | (nm,TheClk) <- ins0' ] ++ error "bad clk_name"+ rst_name = head $ [ Pad nm | (nm,TheRst) <- ins0' ] ++ [Lit (RepValue [Just False])]+ clk_en_name = head $ [ Pad nm | (nm,TheClkEn) <- ins0' ] ++ [Lit (RepValue [Just True])]++ gr1 = map replaceEnv gr++ replaceEnv (u,Entity name outs ins) = (u,Entity name outs+ [ (s,t,case d of+ Pad "clk" -> clk_name+ Pad "rst" -> rst_name+ Pad "clk_en" -> clk_en_name+ other -> other)+ | (s,t,d) <- ins+ ])+++ let rCit = KLEG { theCircuit = gr1+ , theSrcs = [ (nm,fromStdLogicType $ padStdLogicType pad) | (nm,pad) <- ins0' ]+ , theSinks = outpads+ }++ -- find the clock domains++ let start :: [(EntityClock,Set (Driver Unique))]+ start = [( EntityClock $ clk_en_name+ , Set.fromList [ p | (_,_,p) <- theSinks rCit ]+ ) ]++ let theCircuitFM = Map.fromList (theCircuit rCit)++ let follow :: EntityClock -> String -> Unique -> [(EntityClock, Driver Unique)]+ follow clk nm u = case Map.lookup u theCircuitFM of+ Nothing -> []+ Just (Entity (External "upflux") _outs [("i0",_,i0), ("go",_,p)]) ->+ [ (EntityClock $ Port "o_clk_en" u,i0)+ , (clk,p)+ ]+ Just (Entity (External "downflux") _ _)+ | nm == "o0" -> -- do not follow into downflux+ [ ]++ Just (Entity _nm _outs ins) -> [ (clk,dr) | (_,_,dr) <- ins ]++ let normalize :: [(EntityClock, Driver Unique)] -> [(EntityClock, Set (Driver Unique))]+ normalize = map (\ xss -> (fst (head xss),Set.fromList [ p | (_,p) <- xss ]))+ . L.groupBy (\ a b -> fst a == fst b)+ . L.sortBy (comparing fst)+++ -- given a working set, find the next working set.+ let step :: [(EntityClock,Set (Driver Unique))] -> [(EntityClock,Set (Driver Unique))]+ step val = normalize+ [ (c,d)+ | (clk,xs) <- val+ , Port n s <- Set.toList xs+ , (c,d) <- follow clk n s+ ]+++ -- given a previous result, and a new result, figure out the new Uniques (the front)+ let front :: [(EntityClock,Set (Driver Unique))] -> [(EntityClock,Set (Driver Unique))] -> [(EntityClock,Set (Driver Unique))]+ front old new = concat+ [ case (lookup clk old, lookup clk new) of+ (Just o',Just n) -> [(clk,n `Set.difference` o')]+ (Nothing,Just n) -> [(clk,n)]+ (Just _,Nothing) -> []+ _ -> error "internal error"+ | (clk,_) <- new+ ]++ let join :: [(EntityClock,Set (Driver Unique))] -> [(EntityClock,Set (Driver Unique))] -> [(EntityClock,Set (Driver Unique))]+ join old new =+ [ case (lookup clk old, lookup clk new) of+ (Just o',Just n) -> (clk,n `Set.union` o')+ (Nothing,Just n) -> (clk,n)+ (Just o',Nothing) -> (clk,o')+ _ -> error "internal error"+ | clk <- Set.toList (Set.fromList (map fst old) `Set.union` Set.fromList (map fst new))+ ]++ let interp :: [(EntityClock,Set (Driver Unique))] -- working set+ -> [(EntityClock,Set (Driver Unique))] -- new set+ -> IO [(EntityClock,Set (Driver Unique))] -- result+ interp working [] = return working+ interp working new = do+-- print ("working",working)+-- print ("new",new)+ let new' = step new+-- print ("new'",new')+ let working' = join working new'+-- print ("working'",working')+ let new'' = front working new'+-- print ("new''",new'')+ interp working' new''++ clocks <- interp start start++-- let clocks = undefined+++ let uqToClk :: Map (Driver Unique) [EntityClock]+ uqToClk = Map.fromListWith (++)+ [ (port,[clk])+ | (clk,uqs) <- clocks+ , port <- Set.toList uqs+ ]++-- print uqToClk++ return $ rCit { theCircuit =+ [ (u,case e of+ Entity nm outs ins ->+ case clkEnPort nm of+ Nothing -> e+ Just port_nm ->+ let (_,p) = entityFind port_nm e+ in Entity nm outs $+ ins +++ [ case Map.lookup p uqToClk of+ Nothing -> error $ "can not find port: " ++ show p+ Just [EntityClock dr] -> ("clk_en",B,dr)+ Just xs -> error $ "node " ++ show u +++ " has multiple clocks domains " +++ show xs+ ]++ )+ | (u,e) <- theCircuit rCit ]+ }++-- Each one needs a i0 to look at++-- | Return the name of the clock-enable port, given an Id.+clkEnPort :: Id -> Maybe String+clkEnPort (Prim "register") = return "i0"+clkEnPort (Prim "delay") = return "i0"+clkEnPort (Prim "write") = return "wData"+clkEnPort (External "upflux") = return "go"+clkEnPort (External "downflux") = return "i0"+clkEnPort _ = Nothing+++-------------------------------------------------------------------------------+-- | A clock is represented using its 'clock enable'.+data EntityClock = EntityClock (Driver Unique)+ deriving (Eq,Ord,Show)++---------------------------------------------------------------------------------++newtype ExternalStdLogicVector x = ExternalStdLogicVector RepValue+ deriving Show++instance (Size ix) => Rep (ExternalStdLogicVector ix) where+ type W (ExternalStdLogicVector ix) = ix+ data X (ExternalStdLogicVector ix) = XExternalStdLogicVector (ExternalStdLogicVector ix)++ optX (Just b) = XExternalStdLogicVector $ b+ 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)+ showRep = showRepDefault
+ Language/KansasLava/Internal.hs view
@@ -0,0 +1,65 @@+-- | This module is for internal functions used in more than one place+module Language.KansasLava.Internal where++import Data.Maybe as Maybe+import Language.KansasLava.Stream as Stream+import Prelude hiding (tail, lookup)+++takeMaybe :: Maybe Int -> [a] -> [a]+takeMaybe = maybe id take++-- surely this exists in the prelude?+mergeWith :: (a -> a -> a) -> [[a]] -> [a]+mergeWith _ [] = []+mergeWith f ls = foldr1 (Prelude.zipWith f) ls++splitLists :: [[a]] -> [Int] -> [[[a]]]+splitLists xs (i:is) = map (take i) xs : splitLists (map (drop i) xs) is+splitLists _ [] = [[]]+++-- | Stepify allows us to make a stream element-strict.+class Stepify a where+ stepify :: a -> a++-- | Strictly apply a function to each element of a Stream.+stepifyStream :: (a -> ()) -> Stream a -> Stream a+stepifyStream f (Cons a opt_r) = Cons a (f a `seq` case opt_r of+ Nothing -> Nothing+ Just r -> Just $! stepifyStream f r)++-- | A 'Radix' is a trie indexed by bitvectors.+data Radix a+ = Res !a -- ^ A value stored in the tree+ | NoRes -- ^ Non-present value+ -- | A split-node, left corresponds to 'True' key bit, right corresponds to 'False' key bit.+ | Choose !(Radix a) !(Radix a)+ deriving Show++-- | The empty tree+empty :: Radix a+empty = NoRes++-- | Add a value (keyed by the list of bools) into a tree+insert :: [Bool] -> a -> Radix a -> Radix a+insert [] y (Res _) = Res $! y+insert [] y NoRes = Res $! y+insert [] _ (Choose _ _) = error "inserting with short key"+insert xs y NoRes = insert xs y (Choose NoRes NoRes)+insert _ _ (Res _) = error "inserting with too long a key"+insert (True:a) y (Choose l r) = Choose (insert a y l) r+insert (False:a) y (Choose l r) = Choose l (insert a y r)+++-- | Find a value in a radix tree+find :: [Bool] -> Radix a -> Maybe a+find [] (Res v) = Just v+find [] NoRes = Nothing+find [] _ = error "find error with short key"+find (_:_) (Res _) = error "find error with long key"+find (_:_) NoRes = Nothing+find (True:a) (Choose l _) = find a l+find (False:a) (Choose _ r) = find a r++
+ Language/KansasLava/Netlist/Decl.hs view
@@ -0,0 +1,75 @@+-- | This module generates Netlist 'Decl's for a circuit graph.+module Language.KansasLava.Netlist.Decl where++import Language.KansasLava.Types+import Language.Netlist.AST++import Data.Reify.Graph (Unique)++import Language.KansasLava.Netlist.Utils++-- Entities that need a _next special *extra* signal.+--toAddNextSignal :: [Id]+--toAddNextSignal = [Prim "register"]+++-- We have a few exceptions, where we generate some extra signals,+-- but in general, we generate a single signal decl for each+-- entity.+-- | Generate declarations.+genDecl :: (Unique, Entity Unique) -> [Decl]+-- Special cases+{-+genDecl (i,Entity nm outputs _)+ | nm `elem` toAddNextSignal+ = concat+ [ [ NetDecl (next $ sigName n i) (sizedRange nTy) Nothing+ , MemDecl (sigName n i) Nothing (sizedRange nTy)+ ]+ | (n,nTy) <- outputs ]+genDecl (i,e@(Entity nm outputs@[_] inputs)) | nm == Prim "BRAM"+ = concat+ [ [ MemDecl (sigName n i) (memRange aTy) (sizedRange nTy)+ , NetDecl (sigName n i) (sizedRange nTy) Nothing+ ]+ | (n,nTy) <- outputs ]+ where+ aTy = lookupInputType "wAddr" e++genDecl (i,Entity nm outputs _)+ | nm `elem` isVirtualEntity+ = []+-}+-- General case+genDecl (i,e@(Entity _ outputs _))+ = [ case toStdLogicTy nTy of+ MatrixTy x (V y)+ -> let x' = head [ po2 | po2 <- iterate (*2) 1+ , po2 >= x+ ]+ in MemDecl+ (sigName n i)+ (sizedRange (V x'))+ (sizedRange (V y))+ (case e of+ Entity (Prim "rom")+ [("o0",_)]+ [("defs",RomTy _,Lits lits)]+ -- This is reversed because we defined from (n-1) downto 0+ -> Just $ reverse $ map (toTypedExpr (V y))+ $ take x'+ (lits ++ repeat (RepValue $ replicate y $ Just False))+ _ -> Nothing+ )+ _ -> NetDecl+ (sigName n i)+ (sizedRange nTy)+ (case e of+ Entity (Prim "register")+ [("o0",ty)]+ [ _, ("def",GenericTy,gn), _, _, _] ->+ Just (toTypedExpr ty gn)+ _ -> Nothing)+ | (n,nTy) <- outputs+ , toStdLogicTy nTy /= V 0+ ]
+ Language/KansasLava/Netlist/Inst.hs view
@@ -0,0 +1,930 @@+{-# LANGUAGE PatternGuards #-}+-- | The 'Inst' module generates Netlist instances for each 'Entity' in a Lava+-- circuit.+module Language.KansasLava.Netlist.Inst(genInst') where++import Language.KansasLava.Types+import Language.Netlist.AST hiding (U)+import Language.Netlist.Util+import Language.KansasLava.Rep+import qualified Data.Map as M++import Data.List+import Data.Reify.Graph (Unique)++import Language.KansasLava.Netlist.Utils++import Debug.Trace++-- | Generate Netlist Insts for Lava entities.+genInst' :: M.Map Unique (Entity Unique)+ -> Unique+ -> Entity Unique+ -> [Decl]+genInst' env i e =+-- (CommentDecl $ show (i,e)):+ genInst env i e+genInst :: M.Map Unique (Entity Unique) -> Unique -> Entity Unique -> [Decl]++-- (Commented out) debugging hook+-- genInst env i en | trace (show ("genInst",en)) False = undefined++-- Some entities never appear in output (because they are virtual)+--genInst env i (Entity nm ins outs) | nm `elem` isVirtualEntity = []++-- You never actually write something that is zero width.+genInst _ _ (Entity _ [(_,ty)] _) | toStdLogicTy ty == V 0 = []++{-+-- We expand out all the ClkDom's, projecting into the components,+-- for VHDL generation purposes.+genInst env i e@(Entity (Prim nm) outs ins) | length ins2 > 0 =+ genInst env i (Entity (Prim nm) outs (ins' ++ ins2))+ where+ ins' = [ p | p@(nm,ty,dr) <- ins, ty /= ClkDomTy ]++ ins2 = concat+ [ case M.lookup p_id env of+ Just (Entity (Prim "Env") _ ins_e) ->+ [ (env_nm ++ "_" ++ nm,ty,dr)+ | (nm,ty,dr) <- ins_e+ ]+ _ -> error $ "can not find clock domain for " ++ show (p_id,e)+ | (env_nm,ClkDomTy, Port "env" p_id) <- ins+ ]+-}+++-- Blackbox nodes should have been removed by reification, but alas, no.+genInst env i (Entity (BlackBox _) ins outs) =+ genInst env i (Entity (Prim "id") ins outs)++genInst env i (Entity (Prim "retime") outs [("i0",ty,dr),("pulse",_,_)]) =+ genInst env i (Entity (Prim "id") outs [("i0",ty,dr)])++genInst _ _ (Entity (Comment comments) [] []) =+ [ CommentDecl (unlines comments)+ ]+genInst env i (Entity (Comment comments) ins@[_] outs@[_]) =+ CommentDecl (unlines comments) :+ genInst env i (Entity (Prim "id") ins outs)++genInst env i (Entity (Prim "const") outputs [in0,_])+ = genInst env i (Entity (Prim "id") outputs [in0])++genInst env i (Entity (Prim "pair") outputs inputs)+ = genInst' env i (Entity (Prim "concat") outputs inputs)+genInst env i (Entity (Prim "triple") outputs inputs)+ = genInst' env i (Entity (Prim "concat") outputs inputs)+++genInst env i (Entity (Prim "fst") outputs inputs)+ = genInst env i (Entity (Prim "project") outputs (addNum 0 inputs))+genInst env i (Entity (Prim "snd") outputs inputs)+ = genInst' env i (Entity (Prim "project") outputs (addNum 1 inputs))+genInst env i (Entity (Prim "fst3") outputs inputs)+ = genInst env i (Entity (Prim "project") outputs (addNum 0 inputs))+genInst env i (Entity (Prim "snd3") outputs inputs)+ = genInst env i (Entity (Prim "project") outputs (addNum 1 inputs))+genInst env i (Entity (Prim "thd3") outputs inputs)+ = genInst env i (Entity (Prim "project") outputs (addNum 2 inputs))+++-- identity++genInst _ i (Entity (Prim "id") [(vO,tyO)] [(_,tyI,d)]) =+ case toStdLogicTy tyO of+ MatrixTy n (V _)+ -- no need to coerce n[B], because both sides have the+ -- same representation+ -> [ MemAssign (sigName vO i) (ExprLit Nothing $ ExprNum j)+ $ ExprIndex varname+ (ExprLit Nothing $ ExprNum j)+ | j <- [0..(fromIntegral n - 1)]+ ]+ _ -> [ NetAssign (sigName vO i) $ toStdLogicExpr tyI d ]+ where+ -- we assume the expression is a var name for matrix types (no constants here)+ (ExprVar varname) = toStdLogicExpr tyI d++-- Concat and index (join, project)++genInst _ i (Entity (Prim "concat") [("o0",ty)] ins)+ | case toStdLogicTy ty of+ MatrixTy {} -> True+ _ -> False+ =+ [ MemAssign+ (sigName "o0" i)+ (ExprLit Nothing $ ExprNum j)+ (stdLogicToMem tyIn $ toStdLogicExpr tyIn dr)+ | (j,(_,tyIn,dr)) <- zip [0..] ins+ ]++-- hack to handle bit to vector with singleton bools.+genInst env i (Entity (Prim "concat") outs ins@[(_,B,_)]) =+ genInst env i (Entity (Prim "concat")+ outs+ (ins ++ [("_",V 0,Lit (RepValue []))]))++genInst _ i (Entity (Prim "concat") [("o0",_)] inps) =+ [ CommentDecl (show inps)+ , NetAssign (sigName "o0" i) val]+ where val = ExprConcat+ -- Note the the layout is reversed, because the 0 bit is on the right hand size+ [ toStdLogicExpr ty s | (_,ty, s) <- reverse inps ]++genInst _ i (Entity (Prim "index")+ [("o0",_)]+ [("i0", GenericTy, Generic idx),+ ("i1",ty@MatrixTy {},dr)+ ]) =+ [ NetAssign (sigName "o0" i)+ (reverse vs !! (fromIntegral idx))+ ]+ where+ -- we assume the expression is a var name (no constants here, initiaized at startup instead).+ ExprConcat vs = toStdLogicExpr ty dr++genInst _ i e@(Entity (Prim "index")+ [("o0",t)]+ [("i0", ixTy, ix),+ ("i1",ty@MatrixTy {},dr)+ ]) =+ [ NetAssign (sigName "o0" i)+ (memToStdLogic t+ (ExprIndex varname+ (toMemIndex ixTy ix)))+ ]+ where+ -- we assume the expression is a var name (no constants here, initiaized at startup instead).+ varname = case toStdLogicExpr ty dr of+ ExprVar v -> v+ other -> case dr of+ Port v n -> sigName v (fromIntegral n)+ _ -> error (show ("genInst/index",e,other))++genInst _ i (Entity (Prim "unconcat") outs [("i0", ty@(MatrixTy n inTy), dr)])+ | length outs == n =+ [ NetAssign (sigName ('o':show j) i)+ (memToStdLogic inTy+ (ExprIndex varname+ (ExprLit Nothing $ ExprNum j)))+ | (j,_) <- zip [0..] outs+ ]+ where+ -- we assume the expression is a var name (no constants here, initiaized at startup instead).+ (ExprVar varname) = toStdLogicExpr ty dr++genInst _ i e@(Entity (Prim "project")+ [("o0",tyOut)]+ [("i0", GenericTy, Generic ix),+ ("i1",TupleTy tys,input)]) =+ case toStdLogicType tyOut of+ SL ->+ [ NetAssign (sigName "o0" i)+ (prodSlices input tys !! fromIntegral ix)+ ]+ SLV _n ->+ [ NetAssign (sigName "o0" i)+ (prodSlices input tys !! fromIntegral ix)+ ]+ SLVA n _ ->+ -- The trick here is to expand out the matrix to be+ -- imbeaded in the tuple, then to project from there.+ -- So (B,2[U4]) ==> (B,U4,U4)+ let tys' = concat+ [ case ty of+ MatrixTy n' ty' | j == ix -> replicate n' ty'+ _ | j == ix -> error "found a non-Matrix project to a Matrix"+ _ -> [ ty ]+ | (ty,j) <- zip tys [0..] ]+ slices = prodSlices input tys'+ select = take n . drop (fromIntegral ix)+ in+ [ MemAssign (sigName "o0" i)+ (ExprLit Nothing $ ExprNum $ j)+ (stdLogicToMem ty' slice)+ | (j,(ty',slice)) <- zip [0..]+ (select (zip tys' slices))+ ]+ _ -> error $ show ("project",e)++{-+genInst _ i (Entity (Prim "index")+ [("o0",outTy)]+ [("i0", ixTy, ix),+ ("i1",eleTy,input)]) =+ [ NetAssign (sigName "o0" i)+ (ExprCase (toStdLogicExpr ixTy ix)+ [ ([toStdLogicExpr ixTy (idx :: Integer)],toStdLogicExpr outTy val)+ | (idx,val) <- zip [0..] $ prodSlices input tys+ ]+ (Just $ toStdLogicExpr outTy (0 :: Integer))+ )+ ]+ where tys = case eleTy of+ -- Not sure about way this works over two different types.+ MatrixTy sz eleTy' -> replicate sz eleTy'+ TupleTy tys' -> tys'+ other -> error $ show ("genInst/index",other)+-}++{-+genInst env i e@(Entity nm outs ins) | newName nm /= Nothing =+ genInst env i (Entity nm' outs (ins' ++ ins2))+ where+ expandEnv = [Prim "register",Prim "BRAM"]+ newName (Prim "register") = return $ Name "Memory" "register"+ newName (Prim "BRAM") = return $ Name "Memory" "BRAM"+ newName _ = Nothing++ Just nm' = newName nm++ ins' = [ p | p@(nm,ty,dr) <- ins, ty /= ClkDomTy ]+ p_id = shrink+ [ p_id+ | (_, ClkDomTy, Port "env" p_id) <- ins+ ]+ shrink [p] = p+ shrink [p1,p2] | p1 == p2 = p1 -- two clocks, the same actual clock+ shrink p_ids = error $ "Clock domain problem " ++ show (i,e,p_ids)++ ins2 = case M.lookup p_id env of+ Just (Entity (Prim "Env") _ ins_e) -> [ (nm,ty,dr) | (nm,ty,dr) <- ins_e ]+ _ -> error $ "can not find clock domain for " ++ show (p_id,e)+-}++-- Muxes+genInst _ i (Entity (Prim "mux") [("o0",ty)] [("i0",_,Lit (RepValue [Just True])),("i1",fTy,_),("i2",tTy,t)])+ | ty == tTy && ty == fTy+ = assignDecl "o0" i ty $ \ toExpr -> toExpr t+genInst _ i (Entity (Prim "mux") [("o0",ty)] [("i0",_,Lit (RepValue [Just False])),("i1",fTy,f),("i2",tTy,_)])+ | ty == tTy && ty == fTy+ = assignDecl "o0" i ty $ \ toExpr -> toExpr f+genInst _ i (Entity (Prim "mux") [("o0",ty)] [("i0",cTy,c),("i1",fTy,f),("i2",tTy,t)])+ | ty == tTy && ty == fTy+ = assignDecl "o0" i ty $ \ toExpr ->+ (ExprCond cond+ (toExpr t)+ (toExpr f))+ where cond = ExprBinary Equals (toTypedExpr cTy c) (ExprLit Nothing (ExprBit T))++--------------------------------------------------------------------------------------------+-- Sampled+--------------------------------------------------------------------------------------------++-- TODO: check all arguments types are the same+genInst env i (Entity (Prim op) [("o0",ty@(SampledTy m n))] ins)+ | op `elem` ["+","-","*","negate"]+ = genInst env i (Entity (External $ "lava_sampled_" ++ sanitizeName op) [("o0",ty)]+ (ins ++ [ ("frac_width",+ GenericTy,+ Generic $ fromIntegral $ n - log2 m)+ , ("width",GenericTy, Generic $ fromIntegral n)+ ]))+++-- For compares, we need to use one of the arguments.+-- With fixed width, we can just consider the bits to be "signed".+genInst env i (Entity (Prim op) [("o0",B)] [("i0",SampledTy m n,d0),("i1",SampledTy m' n',d1)])+ | op `elem` [".>.",".<.",".>=.",".<=."] && m == m' && n == n+ = genInst env i $ Entity (Prim op) [("o0",B)] [("i0",S n,d0),("i1",S n',d1)]++-- This is only defined over constants that are powers of two.+genInst _ i (Entity (Prim "/") [("o0",SampledTy m n)] [ ("i0",iTy,v), ("i1",_,Lit lit)])+-- = trace (show n)+ | (val' `mod` (2^frac_width) == 0) && (2^(log2 val - 1) == val)+ = [ InstDecl "Sampled_fixedDivPowOfTwo" ("inst" ++ show i)+ [ ("shift_by",ExprLit Nothing (ExprNum $ log2 val - 1))+ , ("frac_width", ExprLit Nothing $ ExprNum $ fromIntegral frac_width)+ , ("width", ExprLit Nothing $ ExprNum $ fromIntegral n)+ ]+ [ ("i0",toStdLogicExpr iTy v)+ ]+ [ ("o0",ExprVar $ sigName "o0" i) ]+ ]+ where val' = fromRepToInteger lit+ val = val' `div` (2 ^ frac_width)+ frac_width = n - log2 m++-- Logic assignments+{-+genInst _ i (Entity (Prim "fromStdLogicVector") [("o0",t_out)] [("i0",t_in,w)]) =+ case (t_in,t_out) of+ (V n,U m) | n == m ->+ [ NetAssign (sigName "o0" i) (toStdLogicExpr t_in w)+ ]+ (V n,V m) | n == m ->+ [ NetAssign (sigName "o0" i) (toStdLogicExpr t_in w)+ ]+ (V n,MatrixTy m B) | n == m ->+ [ NetAssign (sigName "o0" i) (toStdLogicExpr t_in w)+ ]+ (V n,SampledTy _ m) | n == m ->+ [ NetAssign (sigName "o0" i) (toStdLogicExpr t_in w)+ ]+ _ -> error $ "fatal : converting from " ++ show t_in ++ " to " ++ show t_out ++ " using fromStdLogicVector failed"+genInst _ i (Entity (Prim "toStdLogicVector") [("o0",t_out)] [("i0",t_in,w)]) =+ case (t_in,t_out) of+ (U n,V m) | n == m ->+ [ NetAssign (sigName "o0" i) $ toStdLogicExpr t_in w+ ]+ (V n,V m) | n == m ->+ [ NetAssign (sigName "o0" i) $ toStdLogicExpr t_in w+ ]+ (SampledTy _ n,V m) | n == m ->+ [ NetAssign (sigName "o0" i) $ toStdLogicExpr t_in w+ ]+ (MatrixTy n B,V m) | n == m ->+ [ NetAssign (sigName "o0" i) $+ ExprConcat [ memToStdLogic B+ (ExprIndex (slvVarName t_in w)+ (ExprLit Nothing $ ExprNum $ fromIntegral j)+ )+ | j <- reverse [0..(m-1)]+ ]+ ]+ (B,V 1) ->+ [ NetAssign (sigName "o0" i ++ "(0)") $ toStdLogicExpr t_in w -- complete hack+ ]+ _ -> error $ "fatal : converting from " ++ show t_in ++ " to " ++ show t_out ++ " using toStdLogicVector failed"+-}++-- <= x(7 downto 2)++genInst _ i (Entity (Prim "spliceStdLogicVector") [("o0",V outs)] [("i0",_,Generic x),("i1",V ins,w)])+{-+ | outs < (ins - fromIntegral x)+ =+ -- TODO: Still needs more work here to cover all cases+ [ NetAssign (sigName "o0" i)+ $ ExprConcat+ [ ExprSlice nm (ExprLit Nothing (ExprNum $ high)) (ExprLit Nothing (ExprNum low))+ , ExprLit Nothing (ExprNum 1234567)+ ]+ ]+-}++ | null zs =+ [ NetAssign (sigName "o0" i) slice+ ]+ | otherwise =+ [ NetAssign (sigName "o0" i) $ ExprConcat+ [ ExprLit (Just $ length zs) $ ExprBitVector [ F | _ <- zs ]+ , slice+ ]+ ]++ where+ xs = take outs [x..]+ ys = take (ins - fromIntegral x) xs+ zs = drop (ins - fromIntegral x) xs++ slice = ExprSlice nm (ExprLit Nothing (ExprNum $ last ys)) (ExprLit Nothing (ExprNum $ head ys))+++ nm = case toTypedExpr (V ins) w of+ ExprVar n -> n+ _ -> error $ " problem with spliceStdLogicVector " ++ show w++++--------------------------------------------------------------------------------+-- Basic Coerce, with truncation and zero padding+--------------------------------------------------------------------------------++-- coerce only works betwen things of the same width.+-- 9 possible coercions, because we have 3 representaitions.++genInst env i (Entity (Prim "coerce") [("o0",tO)] [("i0",tI,w)])+ | typeWidth tI == typeWidth tO =+ case (toStdLogicTy tI,toStdLogicTy tO) of+ (a,b) | a == b -> genInst env i (Entity (Prim "id") [("o0",tO)] [("i0",tI,w)])+ (MatrixTy 1 (V 1),B) ->+ [ NetAssign (sigName "o0" i)+ (toStdLogicExpr' tI w)+ ]+ (MatrixTy _ _,V _) ->+ [ NetAssign (sigName "o0" i)+ (toStdLogicExpr tI w)+ ]++ (B,MatrixTy 1 (V 1)) ->+ [ MemAssign (sigName "o0" i) (ExprLit Nothing $ ExprNum 0)+ $ stdLogicToMem B+ $ toStdLogicExpr tI w+ ]+ (B,V 1) ->+ [ NetAssign (sigName "o0" i)+ $ stdLogicToMem B+ $ toStdLogicExpr tI w+ ]++ (V _,MatrixTy n0 (V n1)) ->+ [ MemAssign (sigName "o0" i) (ExprLit Nothing $ ExprNum $ fromIntegral $j)+ -- This is 'B' because a V is split into an array of B.+ $ ExprSlice (slvVarName tI w)+ (ExprLit Nothing $ ExprNum $ fromIntegral $ (j + 1) * n1 - 1)+ (ExprLit Nothing $ ExprNum $ fromIntegral $ j * n1)+ | j <- [0..(n0 - 1)]+ ]+ (V 1,B) ->+ [ NetAssign (sigName "o0" i)+ $ memToStdLogic B+ $ toStdLogicExpr tI w+ ]+ other -> error $ "coerce failure: " ++ show other++ | otherwise = error $ "coerce attempting to resize : " ++ show (tO,tI)++genInst _ i (Entity (Prim "unsigned") [("o0",tO)] [("i0",tI,w)])+ | isMatrixStdLogicTy tI = error "input of unsigned uses matrix representation"+ | isMatrixStdLogicTy tO = error "output of unsigned uses matrix representation"+ | typeWidth tI == typeWidth tO && tI == B && isStdLogicVectorTy tO =+ [ NetAssign (sigName "o0" i) $ mkExprConcat $ [(tI,ExprVar nm)]+ ]+ | typeWidth tI == typeWidth tO =+ [ NetAssign (sigName "o0" i) $ toStdLogicExpr tI w+ ]+ | typeWidth tI > typeWidth tO =+ [ NetAssign (sigName "o0" i) $+ case toStdLogicExpr tI w of+ ExprVar nm' -> ExprSlice nm' (ExprLit Nothing (ExprNum (fromIntegral (typeWidth tO - 1))))+ (ExprLit Nothing (ExprNum 0))+ ExprLit _ (ExprNum n) ->+ toTypedExpr+ tO+ n -- TODO: should mod with 2^(width of tO)+ other -> error $ "(signed) problem , tI > tO, " ++ show (w,tI,tO,other)+ ]+ | typeWidth tI < typeWidth tO =+ [ NetAssign (sigName "o0" i) $ ExprConcat+ [ ExprLit (Just zeros) $ ExprBitVector $ replicate zeros F+ , ExprVar nm+ ]+ ]+ where+ zeros = typeWidth tO - typeWidth tI+ nm = case toStdLogicExpr tI w of+ ExprVar n -> n+ other -> error $ " problem with unsigned: " ++ show (w,tI,tO,other)+{-+ lit = case opt_lit of+ Just v -> v+ _ -> error "not lit"++ isLit = isJust opt_lit++ opt_lit = case toStdLogicExpr tI w of+ (ExprLit _ (ExprNum n)) -> return n+ _ -> fail "not ExprLit _ (ExprNum _)"+-}++genInst _ i (Entity (Prim "signed") [("o0",tO)] [("i0",tI,w)])+ | isMatrixStdLogicTy tI = error "input of signed uses matrix representation"+ | isMatrixStdLogicTy tO = error "output of signed uses matrix representation"+ | typeWidth tI == typeWidth tO && tI == B && isStdLogicVectorTy tO =+ [ NetAssign (sigName "o0" i) $ mkExprConcat $ [(tI,ExprVar nm)]+ ]+ | typeWidth tI == typeWidth tO =+ [ NetAssign (sigName "o0" i) $ toStdLogicExpr tI w+ ]+ | typeWidth tI > typeWidth tO =+ [ NetAssign (sigName "o0" i) $+ ExprSlice nm (ExprLit Nothing (ExprNum (fromIntegral (typeWidth tO - 1)))) (ExprLit Nothing (ExprNum 0))+ ]+ | otherwise =+ [ NetAssign (sigName "o0" i) $ ExprConcat $+ replicate zeros+ (ExprIndex nm (ExprLit Nothing (ExprNum (fromIntegral (typeWidth tI - 1)))))+ +++ [ ExprVar nm+ ]+ ]+ where+ zeros = typeWidth tO - typeWidth tI+ nm = case toStdLogicExpr tI w of+ ExprVar n -> n+ other -> error $ " problem with signed: " ++ show (w,tI,tO,other)+++--------------------------------------------------------------------------------+-- Arith+--------------------------------------------------------------------------------++genInst env i (Entity (Prim "*") outs@[("o0",U n)] ins) =+ genInst env i $ Entity (External "lava_unsigned_mul")+ outs+ (ins ++ [("width",GenericTy,Generic $ fromIntegral n)])+genInst env i (Entity (Prim "*") outs@[("o0",S n)] ins) =+ genInst env i $ Entity (External "lava_signed_mul")+ outs+ (ins ++ [("width",GenericTy,Generic $ fromIntegral n)])++-- negate of unsigned things (under Haskell) treats the bits not like logicial negate,+-- but 2s complement negate. So we treat it as such.+genInst env i (Entity (Prim "negate") [("o0",U n)] [("i0",U m,dr)]) =+ genInst env i (Entity (Prim "negate") [("o0",S n)] [("i0",S m,dr)])++-- The specials (from a table). Only Prim's can be special.+-- To revisit RSN.++genInst _ i (Entity (Prim ".==.")+ [("o0",B)]+ [ ("i0",ty0,_)+ , ("i1",_,_)+ ]) | typeWidth ty0 == 0+ =+ [ NetAssign (sigName "o0" i) (ExprLit Nothing (ExprBit T))+ ]+++genInst _ i (Entity n@(Prim _) [("o0",oTy)] ins)+ | Just (NetlistOp arity f) <- lookup n specials, arity == length ins =+ [NetAssign (sigName "o0" i)+ (f oTy [(inTy, driver) | (_,inTy,driver) <- ins])]+++--------------------------------------------------------------------------------+-- Clocked primitives+--------------------------------------------------------------------------------++{-+genInst env i (Entity (Prim "delay")+ outs@[("o0",_)]+ (("i0",ty2,Port "o0" read_id):ins_reg))+ | Maybe.isJust async = -- TODO: need to also check default for undefine-ness+ case async_ins of+ [("i0",ty,Port "o0" write_id),("i1",ty2,dr2)] ->+ case M.lookup write_id env of+ Just (Entity (Prim "write") _ ins_write) ->+ genInst env i $ Entity (Prim "RAM")+ outs+ (checkClock ins_write +++ [ ("sync",GenericTy,Generic 1)+ , ("rAddr",ty2,dr2)+ ])++ o -> error ("found a sync/read without a write in code generator " ++ show (i,write_id,o))+ where+ -- TODO: add check for same clock domain+ checkClock ins_write = ins_write+ async = case M.lookup read_id env of+ Just (Entity (Prim "asyncRead") _ ins) -> Just ins+ _ -> Nothing+ async_ins = Maybe.fromJust async+-}++genInst _ i (Entity (Prim "write") [ ("o0",_) ]+ [ ("clk",ClkTy,clk)+ , ("rst",B,_)+ , ("wEn",B,wEn)+ , ("wAddr",wAddrTy,wAddr)+ , ("wData",wDataTy,wData)+ , ("element_count",GenericTy,_) -- now ignored?+ , ("clk_en",B,clk_en)+ ]) =+ [ mkProcessDecl+ [ ( Event (toStdLogicExpr B clk) PosEdge+ , If (isHigh (toStdLogicExpr B clk_en))+ (If (isHigh (toStdLogicExpr B wEn))+ (statements+ [Assign (ExprIndex (sigName "o0" i)+ (toMemIndex wAddrTy wAddr))+ (stdLogicToMem wDataTy $ toStdLogicExpr wDataTy wData)+ ])+ Nothing)+ Nothing+ )+ ]+ ]+++-- assumes single clock+genInst _ i (Entity (Prim "delay") [("o0",ty)] [ ("i0",tI,d)+ , ("clk",ClkTy,clk)+ , ("rst",B,_)+ , ("clk_en",B,clk_en)+ ]) | ty == tI =+ [ mkProcessDecl+ [ ( Event (toStdLogicExpr B clk) PosEdge+ , If (isHigh (toStdLogicExpr B clk_en))+ (assignStmt "o0" i tI d)+ Nothing+ )+ ]+ ]++genInst _ i (Entity (Prim "register") [("o0",ty)] [ ("i0",tI,d)+ , ("def",GenericTy,n)+ , ("clk",ClkTy,clk)+ , ("rst",B,rst)+ , ("clk_en",B,clk_en)+ ]) | ty == tI =+ [ ProcessDecl+ (Event (toStdLogicExpr B clk) PosEdge)+ (let rst_code = Just ( Event (toStdLogicExpr B rst) PosEdge+ , assignStmt "o0" i ty n+ )+ in case rst of+ Port {} -> rst_code+ Pad {} -> rst_code+ Lit (RepValue [Just False]) -> Nothing+ _ -> error "genInst 'register' has strange reset value"+ )+ ( If (isHigh (toStdLogicExpr B clk_en))+ (assignStmt "o0" i tI d)+ Nothing+ )+ ]++{-+-- OLD CODE+genInst env i (Entity (Prim "delay") outs@[("o0",ty)] ins) =+ case toStdLogicTy ty of+ B -> genInst env i $ boolTrick ["i0","o0"] (inst 1)+ V n -> genInst env i $ inst n+ _ -> error $ "delay typing issue (should not happen)"+ where+ inst n = Entity+ (External "lava_delay")+ outs+ (ins ++ [("width",GenericTy,Generic $ fromIntegral n)])++genInst env i (Entity (Prim "register") outs@[("o0",ty)] ins) =+ case toStdLogicTy ty of+ B -> genInst env i $ boolTrick ["i0","o0"] (inst 1)+ V n -> genInst env i $ inst n+ _ -> error $ "register typing issue (should not happen)"+ where+ inst n = Entity+ (External "lava_register")+ outs+ (ins ++ [("width",GenericTy,Generic $ fromIntegral n)])+-}++-- A bit of a hack to handle Bool or zero-width arguments.+genInst env i (Entity (Prim "RAM") outputs@[("o0",data_ty)] inputs) | goodAddrType addr_ty =+ case (toStdLogicTy data_ty,toStdLogicTy addr_ty) of+ (V n, V 0) -> genInst env i $ zeroArg $ inst n 1+ (B , V 0) -> genInst env i $ boolTrick ["wData","o0"] $ zeroArg $ inst 1 1+ (B , V m) -> genInst env i $ boolTrick ["wData","o0"] $ inst 1 m+ (V n, V m) -> genInst env i $ inst n m+ _ -> error "RAM typing issue (should not happen)"+ where+ ("rAddr",addr_ty,_) = last inputs++{-+ rAddr = case d of+ Port "o0" register_id ->+ case M.lookup register_id env of+ Just (Entity (Prim "register") _ ins) ->+ _ ->+ _ -> error $ ("rAddr",d)+-}+ inst :: Int -> Int -> Entity Int+ inst n m = Entity+ (External "lava_bram")+ outputs+ (inputs ++ [("data_width",GenericTy,Generic $ fromIntegral n)+ ,("addr_width",GenericTy,Generic $ fromIntegral m)+ ])+ zeroArg (Entity nm outs ins) =+ Entity nm outs $+ [ (n,V 1,Lit $ RepValue [Just False])+ | n <- ["wAddr","rAddr"]+ ] +++ [ (n,t,d) | (n,t,d) <- ins, n /= "wAddr"+ && n /= "rAddr"+ ]+ goodAddrType ty =+ case ty of+ U _ -> True+ _ -> error $ "unsupported address type for BRAMs: " ++ show ty+++ -- | External entitites will sometimes have inputs and outputs that are+ -- std_logic_vectors (rather than std_logic) for 1-bit signals. This function+ -- adds the appropriate indexing.+ boolTrick :: [String] -> Entity s -> Entity s+ boolTrick nms (Entity (External nm) outs ins) =+ Entity (External nm)+ [ (trick n,t) | (n,t) <- outs ]+ [ (trick n,t,d) | (n,t,d) <- ins ]+ where+ trick n | n `elem` nms = n ++ "(0)"+ | otherwise = n++ boolTrick _ _ = error "applying bool Trick to non-external entity"++++-- For read, we find the pairing write, and call back for "RAM".+-- This may produce multiple RAMs, if there are multiple reads.++-- This will be called index later.++genInst _ i (Entity (Prim "asyncRead")+ [("o0",ty)]+ [ ("i0",ty1@MatrixTy {},dr1)+ , ("i1",ty2,dr2)+ ]) =+ case (dr1,toStdLogicType ty) of+ (Port v n,SLV _) ->+ [NetAssign (sigName "o0" i)+ (memToStdLogic ty $+ ExprIndex (sigName v (fromIntegral n))+ (toMemIndex ty2 dr2)+ )+ ]+ _ -> error "bad array as input to asyncRead or strange output type"+ where+ MatrixTy _ (V _) = toStdLogicTy ty1++{-+genInst env i (Entity (Prim "asyncRead")+ outs@[("o0",ty)]+ [ ("i0",ty1,Port "o0" read_id)+ , ("i1",ty2,dr2)+ ]) =+ case M.lookup read_id env of+ Just (Entity (Prim "write") _ ins) ->+ genInst env i (Entity (Prim "RAM") outs (ins ++ [ ("sync",GenericTy,Generic 0)+ , ("rAddr",ty2,dr2)+ ]))+ o -> error ("found a read without a write in code generator " ++ show (i,read_id,o))+-}+++genInst _ i (Entity (Prim "rom") [("o0",MatrixTy {})] [(_,RomTy {},_)]) =+ [ CommentDecl (sigName "o0" i ++ " is a constant array") ]++--------------------------------------------------------------------------------++-- And the defaults++-- Right now, we *assume* that every external entity+-- has in and outs of type std_logic[_vector].++genInst _ i (Entity name@(External nm) outputs inputs) =+ trace (show ("mkInst",name,[ t | (_,t) <- outputs ],[ t | (_,t,_) <- inputs ]))+ [ InstDecl nm ("inst" ++ show i)+ [ (n,case x of+ Generic v -> ExprLit Nothing (ExprNum v)+ _ -> error $ "genInst, Generic, " ++ show (n,nTy,x)+ )+ | (n,nTy,x) <- inputs, isGenericTy nTy+ ]+ [ (n,toStdLogicExpr nTy x) | (n,nTy,x) <- inputs, not (isGenericTy nTy) ]+ [ (n,ExprVar $ sigName (fixName nTy n) i) | (n,nTy) <- outputs ]+ ]+ where isGenericTy GenericTy = True+ isGenericTy _ = False++ -- A hack to match 'boolTrick'. Should think again about this+ -- Think of this as a silent (0) at the end of the right hand size.+ fixName B n | "(0)" `isSuffixOf` n = reverse (drop 3 (reverse n))+ fixName _ n = n++-- Idea: table that says you take the Width of i/o Var X, and call it y, for the generics.++genInst _ i (Entity (Function mp) [(vout,tyout)] [(_,tyin,d)]) =+ [ NetAssign (sigName vout i)+ (ExprCase (toStdLogicExpr tyin d)+ [ ([toStdLogicExpr tyin ix],toStdLogicExpr tyout val)+ | (ix,val) <- mp+ ]+ (Just $ toStdLogicExpr tyout (0 :: Integer)) -- replace with unknowns+ )+ ]++genInst _ i other = error $ show ("genInst",i,other)+++--------------------------------------------------------------++data NetlistOperation = NetlistOp Int (Type -> [(Type,Driver Unique)] -> Expr)++mkSpecialUnary+ :: (Type -> Expr -> Expr)+ -> (Type -> Driver Unique -> Expr)+ -> [(String, UnaryOp)]+ -> [(Id, NetlistOperation)]+mkSpecialUnary coerceR coerceF ops =+ [( Prim lavaName+ , NetlistOp 1 (uop netListOp)+ )+ | (lavaName,netListOp) <- ops+ ]+ where uop op fTy [(ity,i)] = coerceR fTy (ExprUnary op (coerceF ity i))+ uop op _ _ = error $ "unary op " ++ show op ++ " can have only one argument"+++mkSpecialBinary+ :: (Type -> Expr -> Expr)+ -> (Type -> Driver Unique -> Expr)+-- -> [String]+ -> [(String, BinaryOp)]+ -> [(Id, NetlistOperation)]+mkSpecialBinary coerceR coerceF ops =+ [( Prim lavaName+ , NetlistOp 2 (binop netListOp)+ )+ | (lavaName,netListOp) <- ops+ ]+ where+ -- re-sign a number, please+ resign sz n = if n >= 2^(sz-1) then n - 2^sz else n+ mkBool True = ExprLit Nothing (ExprBit T)+ mkBool False = ExprLit Nothing (ExprBit F)+ binop op fTy [(lty,l),(rty,r)] =+ case (l,r) of+ (Lit ll,Lit rl)+ -> let il = fromRepToInteger ll+ ir = fromRepToInteger rl+ in case (op,lty,rty) of+ (GreaterThan,S x,S y) -> mkBool (resign x il > resign y ir)+ (Minus,U x,U y) | x == y && il >= ir+ -> toStdLogicExpr fTy (il - ir)+ other -> error $ show ("mkSpecialBinary (constant)",il,ir,other)+ _ -> coerceR fTy (ExprBinary op (coerceF lty l)(coerceF rty r))+ binop op _ _ = error $ "Binary op " ++ show op ++ " must have exactly 2 arguments"+++mkSpecialShifts :: [(String, Ident)] -> [(Id, NetlistOperation)]+mkSpecialShifts ops =+ [(Prim lavaName+ , NetlistOp 2 (binop funName)+ )+ | (lavaName, funName) <- ops+ ]+ where+ binop op fTy [(lty,l),(rty,r)] =+ toStdLogicExpr fTy $ ExprFunCall op [toTypedExpr lty l, toIntegerExpr rty r]+-- toStdLogicExpr fTy $ ExprBinary op (toTypedExpr lty l) (toIntegerExpr rty r)+ binop op _ _ = error $ "Binary op " ++ show op ++ " must have exactly 2 arguments"+++-- testBit returns the bit-value at a specific (constant) bit position+-- of a bit-vector.+-- This generates: invar(indexVal);+mkSpecialTestBit :: [(Id, NetlistOperation)]+mkSpecialTestBit =+ [(Prim lavaName+ , NetlistOp 2 binop+ )+ | lavaName <- ["testBit"]+ ]+ where binop _ [(lty,l),(rty,r)] =+ let (ExprVar varname) = toStdLogicExpr lty l+ in (ExprIndex varname (toIntegerExpr rty r))+ binop _ _ = error "Binary op testBit must have exactly 2 arguments"+++specials :: [(Id, NetlistOperation)]+specials =+ mkSpecialBinary (const active_high) toTypedExpr+ [ (".<.",LessThan)+ , (".>.",GreaterThan)+ , (".<=.",LessEqual)+ , (".>=.",GreaterEqual)+ , (".==.",Equals)+ , ("./=.",NotEquals)+ ]+ ++ mkSpecialBinary toStdLogicExpr toTypedExpr+ [("+",Plus)+ , ("-",Minus)+ , ("/", Divide)+ ]+ ++ mkSpecialBinary (\ _ e -> e) toStdLogicExpr+ [ ("or2",Or), ("and2",And), ("xor2",Xor)+ , ("nand2",Nand), ("nor2",Nor)+ ]+ ++ mkSpecialUnary toStdLogicExpr toTypedExpr+ [("negate",Neg)]+ ++ mkSpecialUnary (\ _ e -> e) toStdLogicExpr+ [("not",LNeg)+ ,("complement",LNeg)+ ]+ ++ mkSpecialTestBit+-- See: http://homepage.ntlworld.com/jonathan.deboynepollard/FGA/bit-shifts-in-vhdl.html+ ++ mkSpecialShifts+ [ ("shiftL", "shift_left")+ , ("shiftR", "shift_right")+ , ("shiftLA", "shift_left") -- overloaded in VHDL+ , ("shiftRA", "shift_right") -- overloaded in VHDL+ , ("rotateL", "rotate_left")+ , ("rotateR", "rotate_right")+ ]++++slvVarName :: (Show v, ToStdLogicExpr v) => Type -> v -> Ident+slvVarName tI w = case toStdLogicExpr tI w of+ ExprVar varname -> varname+ _ -> error $ "Can't get the name of variable " ++ show w++mkProcessDecl :: [(Event, Stmt)] -> Decl+mkProcessDecl [(e,s)] = ProcessDecl e Nothing s+mkProcessDecl _ = error "mkProcessDecl"
+ Language/KansasLava/Netlist/Utils.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- | This module contains a number of utility functions useful for converting+-- Lava circuits to the Netlist AST.+module Language.KansasLava.Netlist.Utils+ (+ ToTypedExpr(..),+ ToStdLogicExpr(..), toStdLogicTy,+ AddNext(..),+ toIntegerExpr,+ sizedRange, sigName,+ isHigh,+ lookupInput, lookupInputType,+ -- Needed for Inst+ isMatrixStdLogicTy, isStdLogicTy, isStdLogicVectorTy,+ sanitizeName,+ active_high, stdLogicToMem, memToStdLogic,+ addNum, prodSlices, toMemIndex,+ mkExprConcat,+ assignStmt, assignDecl+ ) where++import Language.KansasLava.Types+import Language.Netlist.AST hiding (U)+import Language.Netlist.Util+import Language.KansasLava.Rep++import Data.Reify.Graph (Unique)+import Data.List(find,mapAccumL)++-- There are three type "classes" in our generated VHDL.+-- 1. std_logic_vector+-- 2. signed/unsigned+-- 3. integer, as used to index into arrays, etc.+++-- Turn a signal of std_logic[_vector], and+-- turn it into a Typed logic Expr. (signed, unsigned, or as is)+-- based on the given type.++-- | Convert a Lava value of a given type into a Netlist expression.+class ToTypedExpr v where+ -- | Given a type and a value, convert it to a netlist Expr.+ toTypedExpr :: Type -> v -> Expr++instance (Integral 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+ toTypedExpr ty (Port v n) = toTypedExpr ty (sigName v (fromIntegral n))+ toTypedExpr ty (Pad nm) = toTypedExpr ty nm+ toTypedExpr _ other = error $ "toTypedExpr(Driver a): " ++ show other++instance ToTypedExpr String where+ -- From a std_logic* into a typed Expr+ toTypedExpr B nm = ExprVar nm+ toTypedExpr ClkTy nm = ExprVar nm+ toTypedExpr (V _) nm = ExprVar nm+ toTypedExpr (S _) nm = signed $ ExprVar nm+ toTypedExpr (U _) nm = unsigned $ ExprVar nm+ toTypedExpr (TupleTy _) nm = ExprVar nm+ toTypedExpr (MatrixTy _ _) nm = ExprVar nm+ toTypedExpr (SampledTy {}) nm = ExprVar nm+ toTypedExpr _other nm = error $ show ("toTypedExpr",_other,nm)++instance ToTypedExpr Integer where+ -- From a literal into a typed Expr+ toTypedExpr = fromIntegerToExpr++-- | Convert an integer represented by a given Lava type into a netlist Expr.+fromIntegerToExpr :: Type -> Integer -> Expr+fromIntegerToExpr t i =+ case toStdLogicTy t of+ B -> ExprLit Nothing (ExprBit (b (fromInteger i)))+ V n -> ExprLit (Just n) (ExprNum i)+ GenericTy -> ExprLit Nothing (ExprNum i)+ _ -> error "fromIntegerToExpr: was expecting B or V from normalized number"+ where b :: Int -> Bit+ b 0 = F+ b 1 = T+ b _ = error "fromIntegerExpr: bit not of a value 0 or 1"++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" + [ ExprLit Nothing $ ExprNum $ fromRepToInteger r+ , ExprLit Nothing $ ExprNum $ fromIntegral n+ ]+ toTypedExpr (U n) r = ExprFunCall "to_unsigned" + [ ExprLit Nothing $ ExprNum $ fromRepToInteger r+ , ExprLit Nothing $ ExprNum $ fromIntegral n+ ]+ -- suspect generic call here+ toTypedExpr t r = toTypedExpr t (fromRepToInteger r)++-- | Type-directed converstion between Lava values and Netlist expressions.+class ToStdLogicExpr v where+ -- | Turn a value into a std_logic[_vector] Expr, given the appropriate type.+ toStdLogicExpr :: Type -> v -> Expr+ toStdLogicExpr' :: Type -> v -> Expr+ toStdLogicExpr' = toStdLogicExpr++ -- | Turn a value into an access of a specific element of an array.+ -- The Type is type of the element.+ toStdLogicEleExpr :: Int -> Type -> v -> Expr+ toStdLogicEleExpr = error "toStdLogicEleExpr"++instance (Integral a) => ToStdLogicExpr (Driver a) where+ -- From a std_logic* (because you are a driver) into a std_logic.+ toStdLogicExpr ty _+ | typeWidth ty == 0 = ExprVar "\"\""+ toStdLogicExpr ty (Lit n) = toStdLogicExpr ty n+ toStdLogicExpr ty (Generic n) = toStdLogicExpr ty n+ toStdLogicExpr (MatrixTy w ty') (Port v n)+ = mkExprConcat+ [ (ty', memToStdLogic ty' $+ ExprIndex (sigName v (fromIntegral n))+ (ExprLit Nothing $ ExprNum $ fromIntegral (i)))+ | i <- reverse [0..(w-1)]+ ]++ toStdLogicExpr _ (Port v n) = ExprVar (sigName v (fromIntegral n))+ toStdLogicExpr _ (Pad v) = ExprVar v+ toStdLogicExpr _ other = error $ show other++ toStdLogicExpr' (MatrixTy 1 _) (Port v n) =+ memToStdLogic B $+ ExprIndex (sigName v (fromIntegral n))+ (ExprLit Nothing $ ExprNum $ 0)+ toStdLogicExpr' _ _ = error "missing pattern in toStdLogicExpr'"++ toStdLogicEleExpr i ty (Port v n) =+ memToStdLogic ty $+ ExprIndex (sigName v (fromIntegral n))+ (ExprLit Nothing $ ExprNum $ fromIntegral i)+ toStdLogicEleExpr _ _ _ = error "missing pattern in toStdLogicEleExpr"++instance ToStdLogicExpr Integer where+ -- From a literal into a StdLogic Expr+ toStdLogicExpr = fromIntegerToExpr++instance ToStdLogicExpr RepValue where+ toStdLogicExpr t r = toTypedExpr t (fromRepToInteger r)++instance ToStdLogicExpr Expr where+ -- Convert from a typed expression (as noted by the type) back into a std_logic*+ toStdLogicExpr B e = e+ toStdLogicExpr ClkTy e = e+ toStdLogicExpr (V _) e = e+ toStdLogicExpr (TupleTy _) e = e+ toStdLogicExpr (MatrixTy _n _) (ExprVar _nm) = error "BBB"+{-+ ExprConcat+ [ ExprIndex nm+ (ExprLit Nothing $ ExprNum $ fromIntegral i)+ | i <- [0..(n-1)]+ ]+-}+ toStdLogicExpr (S _) e = std_logic_vector e+ toStdLogicExpr (U _) e = std_logic_vector e+ toStdLogicExpr(SampledTy {}) e = e+ toStdLogicExpr _other e = error $ show ("toStdLogicExpr", _other,e)++-- | Convert an integer to a netlist expression, not represented as a Netlist+-- std_logic_vector, though.+class ToIntegerExpr v where+ -- | Given a type and a signal, generate the appropriate Netlist Expr.+ toIntegerExpr :: Type -> v -> Expr++instance (Integral 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+ toIntegerExpr ty other = to_integer (toTypedExpr ty other)++-- TOOD: remove, and replace with toStdLogicType.+-- | Turn a Kansas Lava type into its std_logic[_vector] type (in KL format)+-- There are three possible results (V n, B, MatrixTy n (V m))+-- This function does not have an inverse.+toStdLogicTy :: Type -> Type+toStdLogicTy B = B+toStdLogicTy ClkTy = B+toStdLogicTy (V n) = V n+toStdLogicTy GenericTy = GenericTy+toStdLogicTy (MatrixTy i ty) = MatrixTy i (V $ fromIntegral size)+ where size = typeWidth ty+toStdLogicTy ty = V $ fromIntegral size+ where size = typeWidth ty+++-- | Does this type have a *matrix* representation?+isMatrixStdLogicTy :: Type -> Bool+isMatrixStdLogicTy ty = case toStdLogicType ty of+ SLVA {} -> True+ _ -> False+++isStdLogicTy :: Type -> Bool+isStdLogicTy ty = case toStdLogicType ty of+ SL {} -> True+ _ -> False++isStdLogicVectorTy :: Type -> Bool+isStdLogicVectorTy ty = case toStdLogicType ty of+ SLV {} -> True+ _ -> False++-- | Create a name for a signal.+sigName :: String -> Unique -> String+sigName v d = "sig_" ++ show d ++ "_" ++ v++-- | Given a Lava type, calculate the Netlist Range corresponding to the size.+sizedRange :: Type -> Maybe Range+sizedRange ty = case toStdLogicTy ty of+ B -> Nothing+ V n -> Just $ Range high low+ where high = ExprLit Nothing (ExprNum (fromIntegral n - 1))+ low = ExprLit Nothing (ExprNum 0)+ MatrixTy _ _ -> error "sizedRange: does not support matrix types"+ sty -> error $ "sizedRange: does not support type " ++ show sty++-- * VHDL macros++-- | The netlist representation of the active_high function.+active_high :: Expr -> Expr+active_high d = ExprCond d (ExprLit Nothing (ExprBit T)) (ExprLit Nothing (ExprBit F))++-- | The netlist representation of the VHDL std_logic_vector coercion.+std_logic_vector :: Expr -> Expr+std_logic_vector d = ExprFunCall "std_logic_vector" [d]++-- | The netlist representation of the VHDL unsigned coercion.+unsigned :: Expr -> Expr+unsigned x = ExprFunCall "unsigned" [x]++-- | The netlist representation of the VHDL signed coercion.+signed :: Expr -> Expr+signed x = ExprFunCall "signed" [x]++-- | The netlist representation of the VHDL to_integer coercion.+to_integer :: Expr -> Expr+to_integer e = ExprFunCall "to_integer" [e]++-- | The netlist representation of the isHigh predicate.+isHigh :: Expr -> Expr+isHigh (ExprLit Nothing (ExprBit T)) = ExprVar "true"+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 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++-- Both of these are hacks for memories, that do not use arrays of Bools.+-- | Convert a 'memory' to a std_logic_vector.+memToStdLogic :: Type -> Expr -> Expr+memToStdLogic B e = ExprFunCall "lava_to_std_logic" [e]+memToStdLogic _ e = e++-- | Convert a std_logic_vector to a memory.+stdLogicToMem :: Type -> Expr -> Expr+stdLogicToMem B e = ExprConcat [ExprLit Nothing $ ExprBitVector [],e]+stdLogicToMem _ e = e++-- mkExprConcat always returns a std_logic_vector+-- If there is only one thing, and it is B, then we+-- coerce into a std_logic_vector+mkExprConcat :: [(Type,Expr)] -> Expr+mkExprConcat [(B,e)] = ExprConcat [ExprVar "\"\"",e]+mkExprConcat xs = ExprConcat $ map snd xs++---------------------------------------------------------------------------------------------------+-- Other utils++-- The Type here goes from left to right, but we use it right to left.+-- So [B,U4] => <XXXX:4 to 1><X:0>, because of the convension ordering in our generated VHDL.+-- Notice the result list is in the same order as the argument list.+-- The result is written out as a std_logic[_vector].+-- We assume that the input is *not* a constant (would cause lava-compile-time crash)++-- | Given a value and a list of types, corresponding to tuple element types,+-- generate a list of expressions corresponding to the indexing operations for+-- each tuple element.+prodSlices :: Driver Unique -> [Type] -> [Expr]+prodSlices d tys = reverse $ snd $ mapAccumL f size $ reverse tys+ where size = fromIntegral $ sum (map typeWidth tys) - 1++ nm = case d of+ Port v n -> sigName v n+ Pad v -> v+ Lit {} -> error "projecting into a literal (not implemented yet!)"+ driver -> error "projecting into " ++ show driver ++ " not implemented"++ f :: Integer -> Type -> (Integer,Expr)+ f i B = (i-1,ExprIndex nm (ExprLit Nothing (ExprNum i)))+ f i ty = let w = fromIntegral $ typeWidth ty+ nextIdx = i - w+ in (nextIdx, ExprSlice nm (ExprLit Nothing (ExprNum i))+ (ExprLit Nothing (ExprNum (nextIdx + 1))))++-- | Find some specific (named) input inside the entity.+lookupInput :: (Show b) => String -> Entity b -> Driver b+lookupInput i (Entity _ _ inps) = case find (\(v,_,_) -> v == i) inps of+ Just (_,_,d) -> d+ Nothing -> error $ "lookupInput: Can't find input" ++ show (i,inps)++-- | Find some specific (named) input's type inside the entity.+lookupInputType :: String -> Entity t -> Type+lookupInputType i (Entity _ _ inps) = case find (\(v,_,_) -> v == i) inps of+ Just (_,ty,_) -> ty+ Nothing -> error "lookupInputType: Can't find input"+++-- | Add an integer generic (always named "i0" to an input list.+addNum :: Integer -> [(String,Type,Driver Unique)] -> [(String,Type,Driver Unique)]+addNum i [("i0",ty,d)] = [("i0",GenericTy,Generic i),("i1",ty,d)]+addNum _ _ = error "addNum"+-- TODO: should ty be GenericTy only here?++------------------------------------------------------------------------++-- | The 'AddNext' class is used to uniformly generate the names of 'next' signals.+class AddNext s where+ -- | Given a signal, return the name of the "next" signal.+ next :: s -> s++instance AddNext String where+ next nm = nm ++ "_next"++instance AddNext (Driver i) where+ next (Port v i) = Port (next v) i+ next other = other++------------------------------------------------------------------------------++-- | Convert a string representing a Lava operation to a VHDL-friendly name.+sanitizeName :: String -> String+sanitizeName "+" = "add"+sanitizeName "-" = "sub"+sanitizeName "*" = "mul"+sanitizeName ".>." = "gt"+sanitizeName ".<." = "lt"+sanitizeName ".<=." = "ge"+sanitizeName ".>=." = "le"+-- TODO: Add check for symbols+sanitizeName other = other+++{-+-- Use the log of the resolution + 1 bit for sign+log2 1 = 0+log2 num+ | num > 1 = 1 + log2 (num `div` 2)+ | otherwise = error $ "Can't take the log of negative number " ++ show num+-}++----------------------------------------------++-- Build an assignment statement.+assignStmt :: String -> Unique -> Type -> Driver Unique -> Stmt+assignStmt nm i ty d =+ case toStdLogicType ty of+ SL -> Assign (ExprVar $ sigName nm i) (toStdLogicExpr ty d)+ SLV {} -> Assign (ExprVar $ sigName nm i) (toStdLogicExpr ty d)+ SLVA n m -> statements $+ [ Assign (ExprIndex (sigName nm i)+ (ExprLit Nothing $ ExprNum $ fromIntegral j))+ $ toStdLogicEleExpr j (V m) d+ | j <- [0..(n-1)]+ ]+ G {} -> error "assignStmt {G} ?"++-- | 'assignDecl' takes a name and unique, a target type, and+-- a function that takes a driver-to-expr function, and returns an expr.+assignDecl :: String -> Unique -> Type -> ((Driver Unique -> Expr) -> Expr) -> [Decl]+assignDecl nm i ty f =+ case toStdLogicType ty of+ SL -> [ NetAssign (sigName nm i)+ (f $ toStdLogicExpr ty)+ ]+ SLV {} -> [ NetAssign (sigName nm i)+ (f $ toStdLogicExpr ty)+ ]+ SLVA n m -> [ MemAssign (sigName "o0" i)+ (ExprLit Nothing $ ExprNum $ fromIntegral j)+ (f $ toStdLogicEleExpr j (V m))+ | j <- [0..(n-1)]+ ]+ G {} -> error "assignDecl {G} ?"++--error "assignStmt of Matrix"
+ Language/KansasLava/Optimization.hs view
@@ -0,0 +1,255 @@+-- | The Optimization module performs a number of safe optimizations, such as+-- copy elimination, CSE, and combinatorial identity artifacts:+-- e.g. fst(x,y)-->x. The optimizer is *supposed* to be timing invariant;+-- however, it may change circuit properties such as fanout.+module Language.KansasLava.Optimization+ ( optimizeCircuit+ , OptimizationOpts(..)+ ) where++import Language.KansasLava.Types+import Data.Reify+import Control.Monad++import Data.List+import Data.Default+import Data.Maybe(fromMaybe)+++-- NOTES:+-- We need to update the Lava::id operator, that can take and return *multiple* values.++-- A very simple optimizer.++-- | This returns an optimized version of the Entity, or fails to optimize. |+-- Remove trivial overhead, such a direct projection from a product, pairing+-- after projection, and multiplexers with duplicated data input.+optimizeEntity :: (Unique -> Entity Unique) -> Entity Unique -> Maybe (Entity Unique)+optimizeEntity env (Entity (Prim "fst") [(o0,_)] [(_,_,Port o0' u)]) =+ case env u of+ Entity (Prim "pair") [(o0'',_)] [(i1',t1,p1),(_,_,_)]+ | o0' == o0'' -> return $ replaceWith o0 (i1',t1,p1)+ _ -> Nothing+optimizeEntity env (Entity (Prim "snd") [(o0,_)] [(_,_,Port o0' u)]) =+ case env u of+ Entity (Prim "pair") [(o0'',_)] [(_,_,_),(i2',t2,p2)]+ | o0' == o0'' -> return $ replaceWith o0 (i2',t2,p2)+ _ -> Nothing+optimizeEntity env (Entity (Prim "pair") [(o0,tO)] [(_,_,Port o0' u0),(_,_,Port o1' u1)]) =+ case (env u0,env u1) of+ ( Entity (Prim "fst") [(o0'',_)] [(_,_,p2)]+ , Entity (Prim "snd") [(o1'',_)] [(_,_,p1)]+ ) | o0' == o0'' && o1' == o1'' && p1 == p2 ->+ return $ replaceWith o0 ("o0",tO,p1)+ _ -> Nothing+optimizeEntity _ (Entity (Prim "mux") [(o0,_)] [(_,_,_),(i1 ,tTy,t),(_,_,f)])+ | t == f = return $ replaceWith o0 (i1,tTy,t)+ | otherwise = Nothing+optimizeEntity _ (Entity (BlackBox _) [(o0,_)] [(i0, ti, di)]) =+ return $ replaceWith o0 (i0,ti,di)+optimizeEntity _ _ = Nothing++----------------------------------------------------------------------++replaceWith :: String -> (String, Type, Driver s) -> Entity s+replaceWith o (i,t,other) = Entity (Prim "id") [(o,t)] [(i,t,other)]+--replaceWith (i,t,x) = error $ "replaceWith " ++ show (i,t,x)++----------------------------------------------------------------------++-- | A optimization result will return the result along with an Int representing+-- some metric based on the optimization...+data Opt a = Opt a Int -- [String]++instance Monad Opt where+ return a = Opt a 0+ (Opt a n) >>= k = case k a of+ Opt r m -> Opt r (n + m)+++----------------------------------------------------------------------++-- | Copy elimination. Eliminate 'id' entities by propagating inputs to outputs.+copyElimCircuit :: KLEG -> Opt KLEG+copyElimCircuit rCir = Opt rCir' (length renamings)+ where+ env0 = theCircuit rCir++ rCir' = rCir+ { theSinks =+ [ ( v,t,+ case d of+ Port p u -> fromMaybe (Port p u) (lookup (u, p) renamings)+ Pad v' -> Pad v'+ Lit i -> Lit i+ Error i -> error $ "Found Error : " ++ show (i,v,t,d)+ c -> error $ "copyElimCircuit: " ++ show c+ )+ | (v,t,d) <- theSinks rCir+ ]+ , theCircuit =+ [ (u,case e of+ Entity nm outs ins -> Entity nm outs (map fixInPort ins)+ )+ | (u,e) <- env0+ ]+ }++ renamings = [ ((u,o),other)+ | (u,Entity (Prim "id") [(o,tO)] [(_,tI,other)]) <- env0+ , tO == tI -- should always be, anyway+ ]++ fixInPort (i,t,Port p u) =+ (i,t,fromMaybe (Port p u) (lookup (u, p) renamings))+ fixInPort (i,t,o) = (i,t,o)+++--+-- Starting CSE.+-- | Common subexpression eliminatation.+cseCircuit :: KLEG -> Opt KLEG+cseCircuit rCir = Opt (rCir { theCircuit = concat rCirX }) cseCount+ where++ -- how many CSE's did we spot?+ cseCount = length (theCircuit rCir) - length rCirX++ -- for now, just use show: this is what has changed+ -- optMsg = [ (u,e)+ -- | (u,e) <- (theCircuit rCir)+ -- , not (u `elem` (map fst (map head rCirX)))+ -- ]++ rCirX :: [[(Unique, Entity Unique)]]+ rCirX = map canonicalize+ -- We want to combine anything *except* idents's+ -- because we would just replace them with new idents's (not a problem)+ -- _and_ say we've found some optimization (which *is* a problem).+ $ groupBy (\ (_,b) (_,b') -> (b `mycompare` b') == EQ && not (isId b))+ $ sortBy (\ (_,b) (_,b') -> b `mycompare` b')+ $ theCircuit rCir+++ isId (Entity (Prim "id") _ _) = True+ isId _ = False++ -- The outputs do not form part of the comparison here,+ -- because they *can* be different, without effecting+ -- the CSE opertunity.+ mycompare (Entity nm _ ins)+ (Entity nm' _ ins') =+ chain+ [ nm `compare` nm'+ , ins `compare` ins'+ ]++ chain (LT:_ ) = LT+ chain (GT:_ ) = GT+ chain (EQ:xs) = chain xs+ chain [] = EQ++ -- Build the identites+ canonicalize [] = []+ canonicalize ((u0,e0@(Entity _ outs _)):rest) =+ (u0,e0) : [ ( uX,+ Entity (Prim "id") outs'+ [ (n,t, Port n u0) | (n,t) <- outs ]+ )+ | (uX,Entity _ outs' _) <- rest, length outs == length outs'+ ]++-- | Dead code elimination. Although reifyGraph will only reify the part of the+-- circuit that is reachable, it is possible that additional optimizations will+-- make code unreachable. This pass eliminates those graph nodes.+dceCircuit :: KLEG -> Opt KLEG+dceCircuit rCir = if optCount == 0+ then return rCir+ else Opt rCir' optCount+ where+ optCount = length (theCircuit rCir) - length optCir++ outFrees (_,_,Port _ u) = [u]+ outFrees _ = []++ allNames :: [Unique]+ allNames = nub (concat+ [ case e of+ Entity _ _ outs -> concatMap outFrees outs+ | (_,e) <- theCircuit rCir+ ] ++ concatMap outFrees (theSinks rCir)+ )++ optCir = [ (uq,orig)+ | (uq,orig) <- theCircuit rCir+ , uq `elem` allNames+ ]+ rCir' = rCir { theCircuit = optCir }++-- return Nothing *if* no optimization can be found.+-- | Apply the optimizeEntity optimization.+patternMatchCircuit :: KLEG -> Opt KLEG+patternMatchCircuit rCir = if optCount == 0+ then return rCir -- no changes+ else Opt rCir' optCount+ where+ env0 = theCircuit rCir+ env1 v = fromMaybe (error $ "oops, can not find " ++ show v) (lookup v env0)+ attemptOpt = [ optimizeEntity env1 e | (_,e) <- theCircuit rCir ]+ optCount = length [ () | (Just _) <- attemptOpt ]++ optCir = [ (uq,fromMaybe orig mOpt)+ | ((uq,orig),mOpt) <- zip (theCircuit rCir) attemptOpt+ ]++ rCir' = rCir { theCircuit = optCir }++-- | Apply a number of named optimizations (the first argument) to the+-- input. Optimizations are applied sequentially, but the intermediate results+-- are returned in the resulting list.+optimizeCircuits :: [(String,KLEG -> Opt KLEG)] -> KLEG -> [(String,Opt KLEG)]+optimizeCircuits [] _ = []+optimizeCircuits ((nm,fn):fns) c = (nm,opt) : optimizeCircuits fns c'+ where opt@(Opt c' _) = case fn c of+ Opt _ 0 -> Opt c 0 -- If there was no opts, avoid churn+ res@(Opt _ _) -> res+++-- | Data structure for passing optimization parameters.+data OptimizationOpts = OptimizationOpts+ { optDebugLevel :: Int+ }++instance Default OptimizationOpts+ where+ def = OptimizationOpts+ { optDebugLevel = 0+ }+++-- | Basic optimizations, and assumes reaching a fixpoint.+-- Cleans things up, but does not work too hard, because+-- the VHDL compiler get many of the combinatorial optimizations anyway.+optimizeCircuit :: OptimizationOpts -> KLEG -> IO KLEG+optimizeCircuit options rCir = do+ when debug $ print rCir+ loop (optimizeCircuits (cycle opts) rCir)+ where+ debug = optDebugLevel options > 0+ loop [] = error "optimizeCircuit: loop []"+ loop cs@((nm,Opt code n):_) = do+ when debug $ do+ putStrLn $ "##[" ++ nm ++ "](" ++ show n ++ ")###################################"+ when (n > 0) $ print code+ case cs of+ ((_,Opt c _):_) | and [ num == 0 | (_,Opt _ num) <- take (length opts) cs ] -> return c+ ((_,Opt _ _):rest) -> loop rest+ [] -> error "optimizeCircuit: no optimizations"++ opts = [ ("opt",patternMatchCircuit)+ , ("cse",cseCircuit)+ , ("copy",copyElimCircuit)+ , ("dce",dceCircuit)+ ]++
+ Language/KansasLava/Probes.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, RankNTypes, ExistentialQuantification, ScopedTypeVariables, UndecidableInstances, TypeSynonymInstances, 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 (+ -- * Probes+ probeS, unpackedProbe,+ resetProbesForVCD, snapProbesAsVCD,++ -- * Setting up the debugging mode for probes+ setProbesAsTrace, setShallowProbes, setProbes+ ) where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import qualified Language.KansasLava.Stream as S+import Language.KansasLava.VCD++import Control.Concurrent.MVar+import System.IO.Unsafe+import Data.IORef+++{-# NOINLINE probeS #-}+-- | 'probeS' adds a named probe to the front of a signal.+probeS :: (Rep a) => String -> Signal c a -> Signal c a+probeS str sig = unsafePerformIO $ do+ (ProbeFn fn) <- readIORef probeFn+ return (fn str sig)++-- | 'unpackedProbe' is an unpacked version of 'probeS'.+unpackedProbe :: forall c a p . (Rep a, Pack c a, p ~ Unpacked c a) => String -> p -> p+unpackedProbe nm a = unpack (probeS nm (pack a) :: Signal c a)++data ProbeFn = ProbeFn (forall a i . (Rep a) => String -> Signal i a -> Signal i a)++{-# NOINLINE probeFn #-}+probeFn :: IORef ProbeFn+probeFn = unsafePerformIO $ newIORef $ ProbeFn $ \ _ s -> s++-- | Used internally for initializing debugging hooks, replaces all future calls to probe+-- with the given function.+{-# NOINLINE setProbes #-}+setProbes :: (forall a i . (Rep a) => String -> Signal i a -> Signal i a) -> IO ()+setProbes = writeIORef probeFn . ProbeFn++-- | The callback is called for every element of every probed value, in evaluation order.+-- The arguments are fully evaluted (so printing them will not cause any side-effects of evaluation.+{-# NOINLINE setShallowProbes #-}+setShallowProbes :: (forall a . (Rep a) => String -> Integer -> X a -> X a) -> IO ()+setShallowProbes write = setProbes $ \ nm sig -> shallowMapS (probe_shallow nm) sig+ where+ probe_shallow :: forall a . (Rep a) => String -> S.Stream (X a) -> S.Stream (X a)+ probe_shallow nm = id+ . S.fromList+ . map (\ (i,a) -> write nm i a)+ . zip [0..]+ . S.toList++-- | A simplified API, where each internal probe event is represented+-- as a newline-terminated String, and can be printed, or appended to a file.+--+-- To append to a debugging file, use+--+-- >ghci> setProbesAsTrace $ appendFile "DEBUG.out"+--+-- To write to the screen, use+--+-- >ghci> setProbesAsTrace $ putStr+--+-- You will need to re-execute your program after calling any probe function,+-- so typically this done on the command line, or by puting setProbeAsTrace inside main.+{-# NOINLINE setProbesAsTrace #-}+setProbesAsTrace :: (String -> IO ()) -> IO ()+setProbesAsTrace write = setShallowProbes $ \ nm i a -> unsafePerformIO $ do+ write $ nm ++ "(" ++ show i ++ ")" ++ showRep a ++ "\n"+ return a++-- We keep this thread-safe, just in case.+{-# NOINLINE vcdOfProbes #-}+vcdOfProbes :: MVar VCD+vcdOfProbes = unsafePerformIO $ newEmptyMVar++{-# NOINLINE resetProbesForVCD #-}+resetProbesForVCD :: IO ()+resetProbesForVCD = do+ _ <- tryTakeMVar vcdOfProbes -- for interative use, throw away the old one+ putMVar vcdOfProbes $ VCD []+ setShallowProbes $ \ nm clkNo x -> unsafePerformIO $ do+ vcd <- takeMVar vcdOfProbes+ putMVar vcdOfProbes $ addEvent nm (fromIntegral clkNo) x vcd+ return x+ return ()++{-# NOINLINE snapProbesAsVCD #-}+snapProbesAsVCD :: IO VCD+snapProbesAsVCD = readMVar vcdOfProbes
+ Language/KansasLava/Protocols.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, ParallelListComp, TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes, UndecidableInstances, TypeOperators #-}+module Language.KansasLava.Protocols (+ module Language.KansasLava.Protocols.Enabled,+ module Language.KansasLava.Protocols.Memory,+ module Language.KansasLava.Protocols.AckBox,+ module Language.KansasLava.Protocols.ReadyBox,+ module Language.KansasLava.Protocols.Types,+ module Language.KansasLava.Protocols.Patch+ ) where++import Language.KansasLava.Protocols.Enabled+import Language.KansasLava.Protocols.Memory+import Language.KansasLava.Protocols.AckBox+import Language.KansasLava.Protocols.ReadyBox+import Language.KansasLava.Protocols.Types+import Language.KansasLava.Protocols.Patch
+ Language/KansasLava/Protocols/AckBox.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,+ TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes,+ UndecidableInstances #-}+++-- | This module implements an Ack protocol. In this producer/consumer model,+-- the producer drives the data input of the consumer, using an enable to+-- indicate that data is present. The producer will then keep the data value+-- steady until it receives an Ack from the consumer, at which point it's free+-- to drive the data input with a different value. This assumes that consumer+-- latches the input, as it may change.+module Language.KansasLava.Protocols.AckBox where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Protocols.Enabled+import Language.KansasLava.Protocols.Types+import Language.KansasLava.Protocols.Patch+import Language.KansasLava.Utils+import Language.KansasLava.Probes++import Data.Maybe as Maybe++import qualified Prelude+import Prelude hiding (tail, lookup)+++------------------------------------------------------------------------------------+++{- The convention with handshaken signals is+ ...+ -> (lhs_inp, rhs_inp)+ -> (lhs_out, rhs_out)++OR++ -> (lhs_inp, control_in, rhs_inp)+ -> (lhs_out, control_out, rhs_out)++-}+++-- | Take a list of shallow values and create a stream which can be sent into+-- a FIFO, respecting the write-ready flag that comes out of the FIFO.+toAckBox :: (Rep a, Clock c, sig ~ Signal c)+ => Patch [Maybe a] (sig (Enabled a))+ () (sig Ack)++toAckBox = toAckBox' []++-- | An AckBox producer that will go through a series of wait states after each+-- time it drives the data output.+toAckBox' :: (Rep a, Clock c, sig ~ Signal c)+ => [Int] -- ^ list wait states after every succesful post+ -> Patch [Maybe a] (sig (Enabled a))+ () (sig Ack)++toAckBox' pauses ~(ys,ack) = ((),toS (fn ys (fromS ack) pauses))+ where+-- fn xs cs | trace (show ("fn",take 5 cs,take 5 cs)) False = undefined+ -- send the value *before* checking the Ack++ fn xs ys' [] = fn xs ys' (repeat 0)+ fn (x:xs) ys' (0:ps) = x :+ case (x,ys') of+ (_,Nothing:_) -> error "toAckBox: bad protocol state (1)"+ (Just _,Just (Ack True) :rs) -> fn xs rs ps -- has been written+ (Just _,Just (Ack False):rs) -> fn (x:xs) rs (0:ps) -- not written yet+ (Nothing,Just _:rs) -> fn xs rs ps -- nothing to write (choose to use pause, though)+ (_,[]) -> error "toAckBox: can't handle empty list of values to receive"+ fn (x:xs) rs (p:ps) = Nothing :+ case x of+ -- Allow extra Nothings to be consumed in the gaps+ Nothing -> fn xs (Prelude.tail rs) (pred p:ps)+ Just {} -> fn (x:xs) (Prelude.tail rs) (pred p:ps)+ fn [] ys' ps = fn (Prelude.repeat Nothing) ys' ps+++-- | Take stream from a FIFO and return an asynchronous read-ready flag, which+-- is given back to the FIFO, and a shallow list of values.+-- I'm sure this space-leaks.+fromAckBox :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) [Maybe a]+ (sig Ack) ()+fromAckBox = fromAckBox' []++-- | An ackBox that goes through a series of intermediate states each time+-- consumes a value from the input stream and then issues an Ack.+fromAckBox' :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => [Int]+ -> Patch (sig (Enabled a)) [Maybe a]+ (sig Ack) ()+fromAckBox' pauses ~(inp,_) = (toS (map fst internal), map snd internal)+ where+ internal = fn (fromS inp) pauses++ -- pretty simple API+ fn :: [Maybe (Enabled a)] -> [Int] -> [(Ack,Maybe a)]+ fn xs [] = fn xs (repeat 0)+ fn (Nothing:_) _ = error "found an unknown value in AckBox input"+ fn (Just Nothing:xs) ps = (Ack False,Nothing) : fn xs ps+ fn (Just (Just v):xs) (0:ps) = (Ack True,Just v) : fn xs ps+ fn (_:xs) (p:ps) = (Ack False,Nothing) : fn xs (pred p:ps)+ fn [] _ = error "fromAckBox: ack sequences should never end"++---------------------------------------------------------------------------+-- | 'enableToAckBox' turns an Enabled signal into a (1-sided) Patch.+enabledToAckBox :: (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ () (sig Ack)+enabledToAckBox ~(inp,ack) = ((),res)+ where+ res = register Nothing+ $ cASE [ (isEnabled inp,inp)+ , (fromAck ack, disabledS)+ ] res++-- | 'ackBoxToEnabled' turns the AckBox protocol into the Enabled protocol.+-- The assumptions is the circuit on the right is fast enough to handle the+-- streamed data.+ackBoxToEnabled :: (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) ()+ackBoxToEnabled ~(inp,_) = (toAck ack,out)+ where+ out = inp+ ack = isEnabled inp++++-- | This introduces protocol-compliant delays (in the shallow embedding)+shallowAckBoxBridge :: forall sig c a . (Rep a, Clock c, sig ~ Signal c, Show a)+ => ([Int],[Int])+ -> Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ack)+shallowAckBoxBridge (lhsF,rhsF) = patch+ where+ patch = fromAckBox' lhsF $$ toAckBox' rhsF+++-- | 'probeAckBoxPatch' creates a patch with a named probe, probing the data and ack+-- signals in an Ack interface.++probeAckBoxP :: forall sig a c . (Rep a, Clock c, sig ~ Signal c)+ => String+ -> Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ack)+probeAckBoxP probeName ~(inp, ack_in) = (ack_out, out)+ where+ out = inp+ (_, ack_out) = unpack probed++ probed :: sig (Enabled a, Ack)+ probed = probeS probeName $ pack (inp, ack_in)+++-- A simple way of running a patch+runAckBoxP :: forall sig c a b . (c ~ CLK, sig ~ Signal c, Rep a, Rep b)+ => Patch (sig (Enabled a)) (sig (Enabled b))+ (sig Ack) (sig Ack)+ -> [a] -> [b]+runAckBoxP p as = [ b | Just b <- bs' ]+ where+ as' = map Just as+ bs' = runP (outputP as' $$ toAckBox $$ globalClockP $$ p $$ fromAckBox)+++-- | A sink patch throws away its data input (generating a () data+-- output). 'sinkReadyP' uses an enabled/ack protocol.+sinkAckP :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) ()+ (sig Ack) ()+sinkAckP ~(inp, ()) = (toAck ack, ())+ where+ (ack,_) = unpack inp++-------------------------------------------------------------------------------+-- Source Patches - generate a stream of constant values+-------------------------------------------------------------------------------+++-- | A source patch takes no input and generates a stream of values. It+-- corresponds to a top-level input port. 'sourceReadyP' uses the enabled/ack+-- protocol.++alwaysAckP :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => a+ -> Patch () (sig (Enabled a))+ () (sig Ack)+alwaysAckP baseVal ~((), _) = ((), out)+ where+ out = packEnabled high (pureS baseVal)++------------------------------------------------++-- | stub, no data ever sent.+neverAckP :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch () (sig (Enabled a))+ () (sig Ack)+neverAckP (_,_) = ((),disabledS)+
+ Language/KansasLava/Protocols/Enabled.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,+ TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes,+ UndecidableInstances #-}+++-- | The 'Enabled' module allows the construction of circuits that use+-- additional control logic -- an enable signal -- that externalizes whether a+-- data signal is valid.+module Language.KansasLava.Protocols.Enabled+ (Enabled,+ packEnabled, unpackEnabled,+ enabledVal, isEnabled,+ mapEnabled,+ enabledS, disabledS,+ registerEnabled+ ) where++import Language.KansasLava.Signal+import Language.KansasLava.Rep+import Language.KansasLava.Utils+import Language.KansasLava.Types++-- | Enabled is a synonym for Maybe.+type Enabled a = Maybe a++-- | This is lifting *Comb* because Comb is stateless, and the 'en' Bool being+-- passed on assumes no history, in the 'a -> b' function.+mapEnabled :: (Rep a, Rep b, sig ~ Signal clk) + => (forall clk' . Signal clk' a -> Signal clk' b) + -> sig (Enabled a) -> sig (Enabled b)+mapEnabled f en = pack (en_bool,f en_val)+ where (en_bool,en_val) = unpack en+++-- | Lift a data signal to be an Enabled signal, that's always enabled.+enabledS :: (Rep a, sig ~ Signal clk) => sig a -> sig (Enabled a)+enabledS s = pack (pureS True,s)++-- | Create a signal that's never enabled.+disabledS :: (Rep a, sig ~ Signal clk) => sig (Enabled a)+disabledS = pack (pureS False,undefinedS)++-- | Combine a boolean control signal and an data signal into an enabled signal.+packEnabled :: (Rep a, sig ~ Signal clk) => sig Bool -> sig a -> sig (Enabled a)+packEnabled s1 s2 = pack (s1,s2)++-- | Break the representation of an Enabled signal into a Bool signal (for whether the+-- value is valid) and a signal for the data.+unpackEnabled :: (Rep a, sig ~ Signal clk) => sig (Enabled a) -> (sig Bool, sig a)+unpackEnabled = unpack++-- | Drop the Enabled control from the signal. The output signal will be Rep+-- unknown if the input signal is not enabled.+enabledVal :: (Rep a, sig ~ Signal clk) => sig (Enabled a) -> sig a+enabledVal = snd . unpackEnabled++-- | Determine if the the circuit is enabled.+isEnabled :: (Rep a, sig ~ Signal clk) => sig (Enabled a) -> sig Bool+isEnabled = fst . unpackEnabled++-- | Optionally updatable register, based on the value of the enabled signal.+registerEnabled :: (Rep a, Clock clk, sig ~ Signal clk) => a -> sig (Enabled a) -> sig a+registerEnabled a inp = res+ where+ res = register a+ $ cASE [ (isEnabled inp,enabledVal inp)+ ] res+
+ Language/KansasLava/Protocols/Memory.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies, ParallelListComp, TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes, UndecidableInstances #-}+-- | This module provides abstractions for working with RAMs and ROMs.+module Language.KansasLava.Protocols.Memory where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Stream as Stream+import Language.KansasLava.Types+import Language.KansasLava.Utils+import Language.KansasLava.Protocols.Enabled+import Language.KansasLava.Internal++import Data.Sized.Matrix as M+import Control.Applicative hiding (empty)+import Data.Maybe as Maybe+import Control.Monad++import Prelude hiding (tail)++-- | A Pipe combines an address, data, and an Enabled control line.+type Pipe a d = Enabled (a,d)++-- | A Memory takes in a sequence of addresses, and returns a sequence of data at that address.+type Memory clk a d = Signal clk a -> Signal clk d++-- Does not work for two clocks, *YET*+-- call writeMemory+-- | Write the input pipe to memory, return a circuit that does reads.+writeMemory :: forall a d clk1 sig . (Clock clk1, sig ~ Signal clk1, Size a, Rep a, Rep d)+ => sig (Pipe a d)+ -> sig (a -> d)+writeMemory pipe = res+ where+ -- Adding a 1 cycle delay, to keep the Xilinx tools happy and working.+ -- TODO: figure this out, and fix it properly+ (wEn,pipe') = unpack {- register (pureS Nothing) $ -} pipe+ (addr,dat) = unpack pipe'++ res :: Signal clk1 (a -> d)+ res = Signal shallowRes (D $ Port "o0" $ E entity)++ shallowRes :: Stream (X (a -> d))+ shallowRes = pure (\ m -> XFunction $ \ ix ->+ case getValidRepValue (toRep (optX (Just ix))) of+ Nothing -> optX Nothing+ Just a' -> case find a' m of+ Nothing -> optX Nothing+ Just v -> optX (Just v)+ )+ <*> mem -- (emptyMEM :~ mem)+-- <*> ({- optX Nothing :~ -} shallowS addr2)++ -- This could have more fidelity, and allow you+ -- to say only a single location is undefined+ updates :: Stream (Maybe (Maybe (a,d)))+ updates = id+-- $ observeStream "updates"+ $ stepifyStream (\ a -> case a of+ Nothing -> ()+ Just b -> case b of+ Nothing -> ()+ Just (c,d) -> eval c `seq` eval d `seq` ()+ )+ $ pure (\ e a b ->+ do en' <- unX e+ if not en'+ then return Nothing+ else do+ addr' <- unX a+ dat' <- unX b+ return $ Just (addr',dat')+ ) <*> shallowS wEn+ <*> shallowS addr+ <*> shallowS dat++ mem :: Stream (Radix d)+ mem = id+-- $ observeStream "mem"+ $ stepifyStream (\ a -> a `seq` ())+ $ Cons empty $ Just $ Stream.fromList+ [ case u of+ Nothing -> empty -- unknown again+ Just Nothing -> m+ Just (Just (a,d)) ->+ case getValidRepValue (toRep (optX (Just a))) of+ Just bs -> ((insert $! bs) $! d) $! m+ Nothing -> error "mem: can't get a valid rep value"+ | u <- Stream.toList updates+ | m <- Stream.toList mem+ ]++ entity :: Entity E+ entity =+ Entity (Prim "write")+ [ ("o0",typeOfS res)]+ [ ("clk",ClkTy, Pad "clk")+ , ("rst",B, Pad "rst")+ , ("wEn",typeOfS wEn,unD $ deepS wEn)+ , ("wAddr",typeOfS addr,unD $ deepS addr)+ , ("wData",typeOfS dat,unD $ deepS dat)+ , ("element_count"+ , GenericTy+ , Generic (fromIntegral (M.size (error "witness" :: a)))+ )+ ]+{-+readMemory :: forall a d sig clk . (Clock clk, sig ~ Signal clk, Size a, Rep a, Rep d)+ => sig (a -> d) -> sig a -> sig d+readMemory mem addr = unpack mem addr+-}++-- | Read a series of addresses. Respects the latency of Xilinx BRAMs.+syncRead :: forall a d sig clk . (Clock clk, sig ~ Signal clk, Size a, Rep a, Rep d)+ => sig (a -> d) -> sig a -> sig d+syncRead mem addr = delay (asyncRead mem addr)++-- | Read a series of addresses.+asyncRead :: forall a d sig clk . (Clock clk, sig ~ Signal clk, Size a, Rep a, Rep d)+ => sig (a -> d) -> sig a -> sig d+asyncRead a d = mustAssignSLV $ primXS2 fn "asyncRead" a d+ where fn (XFunction f) a0 = + -- We need to case of XFunction, rather than use unX,+ -- because the function may not be total.+ case unX a0 of+ Just a' -> f a'+ Nothing -> optX Nothing+++-- | memoryToMatrix should be used with caution/simulation only,+-- because this actually clones the memory to allow this to work,+-- generating lots of LUTs and BRAMS.+memoryToMatrix :: (Integral a, Size a, Rep a, Rep d, Clock clk, sig ~ Signal clk)+ => sig (a -> d) -> sig (Matrix a d)+memoryToMatrix mem = pack (forAll $ \ x -> asyncRead mem (pureS x))++-- | Apply a function to the Enabled input signal producing a Pipe.+enabledToPipe :: (Rep x, Rep y, Rep z, sig ~ Signal clk) => (forall j . Signal j x -> Signal j (y,z)) -> sig (Enabled x) -> sig (Pipe y z)+enabledToPipe f se = pack (en, f x)+ where (en,x) = unpack se+++--------------------------------------------------++-- The order here has the function *last*, because it allows+-- for a idiomatic way of writing things+--+-- res = rom inp $ \ a -> ....+--+-- | Generate a read-only memory.+rom :: (Rep a, Rep b, Clock clk) => Signal clk a -> (a -> Maybe b) -> Signal clk b+rom inp fn = delay $ funMap fn inp++---------------------------------
+ Language/KansasLava/Protocols/Patch.hs view
@@ -0,0 +1,824 @@+{-# LANGUAGE DoRec, ScopedTypeVariables, FlexibleContexts, TypeFamilies, ParallelListComp, TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes, UndecidableInstances, TypeOperators, NoMonomorphismRestriction #-}+module Language.KansasLava.Protocols.Patch+ -- (Patch, bus, ($$),+ -- emptyP,forwardP, backwardP,dupP,zipPatch,+ -- fstP,matrixDupP,matrixStackP,matrixZipPatch,+ -- fifo1, fifo2)+ where++import Language.KansasLava.Protocols.Enabled+import Language.KansasLava.Protocols.Types++import Language.KansasLava.Rep+import Language.KansasLava.Types+import Language.KansasLava.Utils+import Language.KansasLava.Signal+--import Language.KansasLava.Probes++import Data.Sized.Unsigned (U8)+import Data.Sized.Matrix as M++import qualified Data.ByteString.Lazy as B+import Control.Applicative+import Control.Monad.Fix++---------------------------------------------------------------------------+-- The Patch.+---------------------------------------------------------------------------++-- | A Patch is a data signal with an associated control signal. The 'lhs_in'+-- type parameter is the type of the data input, the 'rhs_out' type parameter is+-- the type of the data output. The 'rhs_in' is the type of the control input+-- (e.g. a 'ready' signal), and the 'lhs_out' is the type of the control output+-- (e.g. 'ack').+type Patch lhs_in rhs_out+ lhs_out rhs_in+ = (lhs_in,rhs_in) -> (lhs_out,rhs_out)++---------------------------------------------------------------------------+-- Executing the Patch, monadic style.+---------------------------------------------------------------------------++-- | outputP produces a constant data output. The control inputs/outputs are+-- unit, so they contain no data.+outputP :: a -> Patch () a+ () ()+outputP a = \ _ -> ((),a)+++runP :: (Unit u1, Unit u2)+ => Patch u1 a+ u2 () -> a+runP p = a+ where+ (_,a) = p (unit,unit)++execP :: Patch a b+ c d+ -> (a,d) -> (c,b)+execP = id+++-- | A patch that passes through data and control.+emptyP :: Patch a a+ b b+emptyP ~(a,b) = (b,a)++-- | Given a patch, add to the data and control inputs/outputs a second set of+-- signals that are passed-through. The signals of the argument patch to fstP+-- will appear as the first element of the pair in the resulting patch.+fstP :: Patch a b+ c e -> Patch (a :> f) (b :> f)+ (c :> g) (e :> g)+fstP p = p `stackP` emptyP++-- | Given a patch, add to the data and control inputs/outputs a second set of+-- signals that are passed-through. The signals of the argument patch to sndP+-- will appear as the second element of the pair in the resulting patch.+sndP :: Patch a b+ c d -> Patch (f :> a) (f :> b)+ (g :> c) (g :> d)+sndP p = emptyP `stackP` p++{-+-- | 'matrixSplicePatch' splices/inserts a patch into a matrix of signals at the position+-- given by index. (Note: The first position is index 0)+matrixSplicePatch :: (Size x, Integral x)+ => x+ -> Patch a a+ b b -> Patch (Matrix x a) (Matrix x a)+ (Matrix x b) (Matrix x b)+matrixSplicePatch index p ~(mlhs_in, mrhs_in) = (mlhs_out, mrhs_out)+ where+ lhs_in = mlhs_in M.! index+ rhs_in = mrhs_in M.! index++ (lhs_out, rhs_out) = p (lhs_in, rhs_in)++ indexInt = (fromIntegral index) :: Int+ mlhs_out = M.matrix $ (take indexInt $ M.toList mrhs_in) ++ lhs_out:(drop (indexInt+1) $ M.toList mrhs_in)+ mrhs_out = M.matrix $ (take indexInt $ M.toList mlhs_in) ++ rhs_out:(drop (indexInt+1) $ M.toList mlhs_in)+-}++-- | Lift a function to a patch, applying the function to the data input.+forwardP :: (li -> ro)+ -> Patch li ro+ b b+forwardP f1 ~(li,ri) = (ri,f1 li)++-- | Lift a function to a patch, applying the function to the control input.+backwardP :: (ri -> lo)+ -> Patch a a+ lo ri+backwardP f2 ~(li,ri) = (f2 ri,li)++-- TODO: above or ??++infixr 3 `stackP`+-- | Given two patches, tuple their data/control inputs and outputs.+stackP :: Patch li1 ro1+ lo1 ri1+ -> Patch li2 ro2+ lo2 ri2+ -> Patch (li1 :> li2) (ro1 :> ro2)+ (lo1 :> lo2) (ri1 :> ri2)+stackP p1 p2 inp = (lo1 :> lo2,ro1 :> ro2)+ where+ (li1 :> li2,ri1 :> ri2) = inp+ (lo1,ro1) = p1 (li1,ri1)+ (lo2,ro2) = p2 (li2,ri2)++-- | Given a homogeneous list (Matrix) of patches, combine them into a single+-- patch, collecting the data/control inputs/outputs into matrices.+matrixStackP :: (m ~ (Matrix x), Size x)+ => m (Patch li ro+ lo ri)+ -> Patch (m li) (m ro)+ (m lo) (m ri)+matrixStackP m inp = ( fmap (\ (l,_) -> l) m'+ , fmap (\ (_,r) -> r) m'+ )+ where+ (m_li,m_ri) = inp+ m' = (\ p li ri -> p (li,ri)) <$> m <*> m_li <*> m_ri+++-- | loopP is a fixpoint style combinator, for backedges.+loopP :: Patch (a :> b) (a :> c)+ (d :> e) (d :> f)+ -> Patch b c+ e f+loopP g ~(b,f) = (e,c)+ where+ (d:>e,a:>c) = g (a:>b,d:>f)++openP :: Patch c (() :> c)+ d (() :> d)+openP = forwardP (\ a -> (() :> a)) $$+ backwardP (\ ~(_ :> a) -> a)+{-+swapP :: (a :> b) -> (b :> a)+assocP :: ((a :> b) :> c) -> (a :> b :> c)+unassocP :: (a :> b :> c) -> ((a :> b) :> c)+closeP :: (() :> b) -> b+copyP :: a -> (a :> a) -- is DUP+-}++-------------------------------------------------------------------------------+-- maping a combinatorial circuit over a protocol.+-------------------------------------------------------------------------------++mapP :: forall a b c sig ack . (Rep a, Rep b, Clock c, sig ~ Signal c)+ => (forall clk' . Signal clk' a -> Signal clk' b)+ -> Patch (sig (Enabled a)) (sig (Enabled b))+ (ack) (ack)+mapP = forwardP . mapEnabled++------------------------------------------------+-- Unit+------------------------------------------------++-- | An instance of the Unit type contains a value that carries no information.+class Unit unit where+ -- | The name of the specific value.+ unit :: unit+++unUnit :: (Unit unit) => unit -> ()+unUnit _ = ()++instance Unit () where unit = ()+instance (Unit a,Unit b) => Unit (a,b) where unit = (unit,unit)+instance (Unit a,Unit b) => Unit (a :> b) where unit = (unit :> unit)+instance (Unit a,Size x) => Unit (Matrix x a) where unit = pure unit++------------------------------------------------+-- File I/O for Patches+------------------------------------------------++-- | 'rawReadP' reads a binary file into Patch, which will become the+-- lefthand side of a chain of patches.+rawReadP :: FilePath -> IO (Patch () [Maybe U8]+ () ())+rawReadP fileName = do+ fileContents <- B.readFile fileName+ return $ outputP $ map (Just . fromIntegral) $ B.unpack fileContents++-- | 'readPatch' reads an encoded file into Patch, which will become the+-- lefthand side of a chain of patches.+readP :: (Read a)+ => FilePath -> IO (Patch () [Maybe a]+ () ())+readP fileName = do+ fileContents <- readFile fileName+ return $ outputP $ map (Just . read) $ words $ fileContents++-- | 'rawWriteP' runs a complete circuit for the given+-- number of cycles, writing the result to a given file in binary format.+rawWriteP :: (Unit u1, Unit u2)+ => FilePath+ -> Int+ -> Patch u1 [Maybe U8]+ u2 ()+ -> IO ()+rawWriteP fileName n patch = do+ B.writeFile fileName $ B.pack [ fromIntegral x | Just x <- take n $ runP patch ]++-- | 'writeP' runs a complete circuit for the given+-- number of cycles, writing the result to a given file in string format.+writeP :: (Show a, Unit u1, Unit u2)+ => FilePath+ -> Int+ -> Patch u1 [Maybe a]+ u2 ()+ -> IO ()+writeP fileName n patch = do+ writeFile fileName $ unlines [ show x | Just x <- take n $ runP patch ]++{-+-- | 'compareP' compares the input to the contents of a file, if there+-- there a mismatch, it will print a message giving the element number that+-- failed. If everything matches, it prints out a "Passed" message+compareP :: (Read a, Show a, Eq a, Unit u1, Unit u2)+ => FilePath+ -> Int+ -> Patch u1 [Maybe a]+ u2 ()+ -> IO (Patch () [Maybe a]+ () () )+compareP fileName n patch = do+ fileContents <- readFile fileName+ let expectedVals = map read $ words $ fileContents+ listCompareP expectedVals n patch++-- | 'listCompareP' compares the input to the contents of a list, if+-- there is a mismatch, it will print a message giving the element number+-- that failed. If everything matches, it prints out a "Passed" message+listCompareP :: (Read a, Show a, Eq a, Unit u1, Unit u2)+ => [a]+ -> Int+ -> Patch u1 [Maybe a]+ u2 ()+ -> IO (Patch () [Maybe a]+ () () )+listCompareP expectedVals n patch = do+ let inp = runP patch+ let incomingVals = [ x | Just x <- take n $ inp ]+ putStr $ checkAgainstList 0 expectedVals incomingVals+ return $ outputP inp+ where+ checkAgainstList :: (Show a, Eq a) => Int -> [a] -> [a] -> String+ checkAgainstList elemNum [] _ = "Passed, quantity compared: " ++ (show elemNum)+ checkAgainstList elemNum _ [] = "Passed, but some data in file was not reached, quantity compared: " ++ (show elemNum)+ checkAgainstList elemNum (e:exs) (i:ins) | (e==i) = checkAgainstList (elemNum+1) exs ins+ checkAgainstList elemNum (e:_) (i:_) = "Failed: Element " ++ (show (elemNum+1)) ++ ": \tExpected: " ++ (show e) ++ " \tActual: " ++ (show i)+-}++---------------------------------------------------------------------------+-- Functions that connect streams+---------------------------------------------------------------------------++-- | ($$) composes two patches serially, sharing a common control protocol. The+-- data output of the first patch is fed to the data input of the second+-- patch. The control output of the second patch is fed to the control input of+-- the first patch, and the control output of the first patch is fed to the+-- control input of the second patch.+infixr 5 $$+($$) ::+ Patch li1 o+ lo1 i+ -> Patch o ro2+ i ri2+ -> Patch li1 ro2+ lo1 ri2+(p1 $$ p2) inp = (lhs_out1,rhs_out2)+ where+ (lhs_in,rhs_in) = inp+ (lhs_out1,rhs_out1) = p1 (lhs_in,lhs_out2)+ (lhs_out2,rhs_out2) = p2 (rhs_out1,rhs_in)++-- | 'readyToAckBridge' converts from a ready interface to an ACK interface+-- by preemptively giving the ready signal, and holding the resulting data+-- from the device on the input side if no ACK is received by the device on+-- the output side. If data is currently being held, then the ready signal+-- will not be given. This bridge is fine for deep embedding (can be+-- represented in hardware).+readyToAckBridge :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ready) (sig Ack)+readyToAckBridge ~(inp, ack_in0) = (toReady ready, out)+ where+ (in_en, in_val) = unpack inp+ ack_in = fromAck ack_in0++ captureData = in_en .&&. bitNot dataHeld .&&. bitNot ack_in++ dataHolder = delay+ $ cASE [ (captureData, in_val)+ ] dataHolder++ dataHeld = register False+ $ cASE [ (captureData, high)+ , (ack_in, low)+ ] dataHeld++ out = cASE [ (dataHeld, packEnabled dataHeld dataHolder)+ ] inp++ ready = bitNot dataHeld++-- | 'ackToReadyBridge' converts from a Ack interface to an Ready interface+-- by ANDing the ready signal from the receiving component with the input+-- enable from the sending component. This may not be necessary at times+-- if the sending component ignores ACKs when no data is sent. This bridge+-- is fine for deep embedding (can be represented in hardware).+ackToReadyBridge :: (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ready)+ackToReadyBridge ~(inp, ready_in) = (toAck ack, out)+ where+ out = inp+ ack = (fromReady ready_in) .&&. (isEnabled inp)++---------------------------------------------------------------------------------+-- Functions that fork streams.+---------------------------------------------------------------------------------++-- | This duplicates the incomming datum.+-- This has the behavior that neither branch sees the value+-- until both can recieve it.++dupP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)+ => Patch (sig (Enabled a)) (sig (Enabled a) :> sig (Enabled a))+ (sig Ack) (sig Ack :> sig Ack)++dupP ~(inp,ack1 :> ack2) = (toAck have_read,out1 :> out2)+ where+ have_read = (state .==. 0) .&&. isEnabled inp+ written1 = (state ./=. 0) .&&. fromAck ack1+ written2 = (state ./=. 0) .&&. fromAck ack2++ state :: sig X4+ state = register 0+ $ cASE [ (have_read, pureS 1)+ , (written1 .&&. written2, pureS 0)+ , (written1 .&&. state .==. 1, pureS 3)+ , (written2 .&&. state .==. 1, pureS 2)+ , (written1 .&&. state .==. 2, pureS 0)+ , (written2 .&&. state .==. 3, pureS 0)+ ] state++ store :: sig a+ store = cASE [ (have_read,enabledVal inp)+ ]+ $ delay store++ out1 = packEnabled (state .==. 1 .||. state .==. 2) store+ out2 = packEnabled (state .==. 1 .||. state .==. 3) store++-- | This duplicate the incoming datam over many handshaken streams.+matrixDupP :: (Clock c, sig ~ Signal c, Rep a, Size x)+ => Patch (sig (Enabled a)) (Matrix x (sig (Enabled a)))+ (sig Ack) (Matrix x (sig Ack))+matrixDupP = ackToReadyBridge $$ matrixDupP' $$ matrixStackP (pure readyToAckBridge) where+ matrixDupP' ~(inp,readys) = (toReady go, pure out)+ where+ go = foldr1 (.&&.) $ map fromReady $ M.toList readys+ out = packEnabled (go .&&. isEnabled inp) (enabledVal inp)++-- | unzipP creates a patch that takes in an Enabled data pair, and produces a+-- pair of Enabled data outputs.+unzipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)+ => Patch (sig (Enabled (a,b))) (sig (Enabled a) :> sig (Enabled b))+ (sig Ack) (sig Ack :> sig Ack)+unzipP = dupP $$+ stackP (forwardP $ mapEnabled (fst . unpack))+ (forwardP $ mapEnabled (snd . unpack))++-- | matrixUnzipP is the generalization of unzipP to homogeneous matrices.+matrixUnzipP :: (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)+ => Patch (sig (Enabled (Matrix x a))) (Matrix x (sig (Enabled a)))+ (sig Ack) (Matrix x (sig Ack))+matrixUnzipP =+ matrixDupP $$+ matrixStackP (forAll $ \ x -> forwardP (mapEnabled $ \ v -> v .!. pureS x))++-- | TODO: Andy write docs for this.+deMuxP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)+ => Patch (sig (Enabled Bool) :> sig (Enabled a)) (sig (Enabled a) :> sig (Enabled a))+ (sig Ack :> sig Ack) (sig Ack :> sig Ack)+deMuxP = fe $$ matrixDeMuxP $$ be+ where+-- fe = fstP (forwardP ((unsigned)))+ fe = fstP (mapP (unsigned))+ be = backwardP (\ ~(b :> c) -> matrix [c,b]) $$+ forwardP (\ m -> ((m M.! (1 :: X2)) :> (m M.! 0)))++-- | matrixDeMuxP is the generalization of deMuxP to a matrix of signals.+matrixDeMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)+ => Patch (sig (Enabled x) :> sig (Enabled a)) (Matrix x (sig (Enabled a)))+ (sig Ack :> sig Ack) (Matrix x (sig Ack))+matrixDeMuxP = matrixDeMuxP' $$ matrixStackP (pure readyToAckBridge) where+ matrixDeMuxP' ~(ix :> inp, m_ready) = (toAck ackCond :> toAck ackIn,out)+ where+ -- set when ready to try go+ go = isEnabled ix .&&. isEnabled inp .&&. fromReady (pack m_ready .!. enabledVal ix)++ -- outputs+ ackCond = go+ ackIn = go+ out = forAll $ \ x -> packEnabled (go .&&. enabledVal ix .==. pureS x) (enabledVal inp)++---------------------------------------------------------------------------------+-- Functions that combine streams+---------------------------------------------------------------------------------++-- no unDup (requires some function / operation, use zipP).++-- | Combine two enabled data inputs into a single Enabled tupled data input.+zipP :: (Clock c, sig ~ Signal c, Rep a, Rep b)+ => Patch (sig (Enabled a) :> sig (Enabled b)) (sig (Enabled (a,b)))+ (sig Ack :> sig Ack) (sig Ack)+zipP ~(in1 :> in2, outReady) = (toAck ack :> toAck ack, out)+ where+ try = isEnabled in1 .&&. isEnabled in2+ ack = try .&&. fromAck outReady++ out = packEnabled try (pack (enabledVal in1, enabledVal in2))++-- | Extension of zipP to homogeneous matrices.+matrixZipP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)+ => Patch (Matrix x (sig (Enabled a))) (sig (Enabled (Matrix x a)))+ (Matrix x (sig Ack)) (sig Ack)+matrixZipP ~(mIn, outReady) = (mAcks, out)+ where+ try = foldr1 (.&&.) (map isEnabled $ M.toList mIn)++ mAcks = fmap toAck $ pure (try .&&. fromAck outReady)+ mIn' = fmap enabledVal mIn+ out = packEnabled try (pack mIn' :: sig (Matrix x a))++-- | 'muxP' chooses a the 2nd or 3rd value, based on the Boolean value.+muxP :: (Clock c, sig ~ Signal c, Rep a)+ => Patch (sig (Enabled Bool) :> sig (Enabled a) :> sig (Enabled a)) (sig (Enabled a))+ (sig Ack :> sig Ack :> sig Ack) (sig Ack)++muxP = fe $$ matrixMuxP+ where+ fe = forwardP (\ ~(a :> b :> c) -> (mapEnabled (unsigned) a :> matrix [c,b])) $$+ backwardP (\ ~(a :> m) -> (a :> (m M.! (1 :: X2)) :> (m M.! 0)))+++-- | 'matrixMuxP' chooses the n-th value, based on the index value.+matrixMuxP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x)+ => Patch (sig (Enabled x) :> Matrix x (sig (Enabled a))) (sig (Enabled a))+ (sig Ack :> Matrix x (sig Ack)) (sig Ack)+matrixMuxP ~(~(cond :> m),ack) = ((toAck ackCond :> fmap toAck m_acks),out)+ where+ -- set when conditional value on cond port+ try = isEnabled cond++ -- only respond/ack when you are ready to go, the correct lane, and have input+ gos :: Matrix x (sig Bool)+ gos = forEach m $ \ x inp -> try+ .&&. (enabledVal cond .==. pureS x)+ .&&. isEnabled inp++ ackCond = foldr1 (.||.) $ M.toList m_acks+ m_acks = fmap (\ g -> g .&&. fromAck ack) gos++ out = cASE (zip (M.toList gos) (M.toList m)) -- only one can ever be true+ disabledS++---------------------------------------------------------------------------------+-- Trivial FIFOs+---------------------------------------------------------------------------------++-- (There are larger FIFO's in the Kansas Lava Cores package.)++-- | FIFO with depth 1.+fifo1 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ack)+fifo1 ~(inp,ack) = (toAck have_read, out)+ where+ have_read = (state .==. 0) .&&. isEnabled inp+ written = (state .==. 1) .&&. fromAck ack++ state :: sig X2+ state = register 0+ $ cASE [ (have_read, pureS 1)+ , (written, pureS 0)+ ] state+++ store :: sig a+ store = delay+ $ cASE [ (have_read,enabledVal inp)+ ]+ store++ out = packEnabled (state .==. 1) store++-- | FIFO with depth 2.+fifo2 :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)+ => Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ack)+fifo2 = ackToReadyBridge $$ fifo2' where+ fifo2' ~(inp,ack) = (toReady ready, out)+ where+ dataIncoming = isEnabled inp++ dataOutRead = (state ./=. 0) .&&. fromAck ack++ -- State:+ -- 0 = First empty, second empty+ -- 1 = First full, second empty+ -- 2 = First empty, second full+ -- 3 = First full, second full, read second store+ -- 4 = First full, second full, read first store+ state :: sig X5+ state = register 0+ $ cASE [ ((state.==.0) .&&. dataIncoming, 1)+ , ((state.==.1) .&&. dataIncoming .&&. dataOutRead, 2)+ , ((state.==.1) .&&. dataIncoming, 4)+ , ((state.==.1) .&&. dataOutRead, 0)+ , ((state.==.2) .&&. dataIncoming .&&. dataOutRead, 1)+ , ((state.==.2) .&&. dataIncoming, 3)+ , ((state.==.2) .&&. dataOutRead, 0)+ , ((state.==.3) .&&. dataOutRead, 1)+ , ((state.==.4) .&&. dataOutRead, 2)+ ] state++ fstStore :: sig a+ fstStore = cASE [ (((state.==.0) .||. (state.==.2)) .&&. dataIncoming, enabledVal inp)+ ]+ $ delay fstStore++ sndStore :: sig a+ sndStore = cASE [ ((state.==.1) .&&. dataIncoming, enabledVal inp)+ ]+ $ delay sndStore++ ready = (state ./=. 3) .&&. (state ./=. 4)++ outval = cASE [ (((state.==.2) .||. (state.==.3)), sndStore)+ ] fstStore++ out = packEnabled (state ./=. 0) outval+++---------------------------------------------------------------------------------+-- Retiming+---------------------------------------------------------------------------------++-- | 'matrixToElementsP' turns a matrix into a sequences of elements from the array, in ascending order.+matrixToElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)+ => Patch (sig (Enabled (Matrix x a))) (sig (Enabled a))+ (sig Ack) (sig Ack)+matrixToElementsP =+ openP+ $$ stackP+ (cycleP (coord :: Matrix x x))+ (matrixUnzipP)+ $$ matrixMuxP++-- | 'matrixFromElementsP' turns a sequence of elements (in ascending order) into a matrix.+-- ascending order.+matrixFromElementsP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)+ => Patch (sig (Enabled a)) (sig (Enabled (Matrix x a)))+ (sig Ack) (sig Ack)+matrixFromElementsP =+ openP+ $$ fstP (cycleP (coord :: Matrix x x))+ $$ matrixDeMuxP+ $$ matrixZipP++---------------------------------------------------------------------------------+-- Other stuff+---------------------------------------------------------------------------------++-- | globalClockP forces the handshaking to use the CLK clock. Which is useful for testing.+globalClockP :: (clk ~ CLK, sig ~ Signal clk) =>+ Patch (sig a) (sig a)+ (sig b) (sig b)+globalClockP ~(li,ri) = (ri,li)++-- | cycleP cycles through a constant list (actually a matrix) of values.+-- Generates an async ROM on hardware.+cycleP :: forall a c ix sig .+ ( Size ix+ , Rep a+ , Rep ix+ , Num ix+ , Clock c+ , sig ~ Signal c+ )+ => Matrix ix a+ -> Patch () (sig (Enabled a))+ () (sig Ack)+cycleP m ~(_,ack) = ((),out)+ where+ ix :: sig ix+ ix = register 0+ $ cASE [ (fromAck ack, loopingIncS ix) ]+ ix++ out = packEnabled high+ $ funMap (\ x -> return (m M.! x))+ ix++constP :: forall a c ix sig .+ ( Size ix+ , Rep a+ , Rep ix+ , Num ix+ , Clock c+ , sig ~ Signal c+ )+ => Matrix ix a+ -> Patch () (sig (Enabled a))+ () (sig Ack)+constP m ~(_,ackOut) = ((),out)+ where+ ix :: sig ix+ ix = register 0+ $ cASE [ (fromAck ackOut, loopingIncS ix) ]+ ix++ st :: sig Bool+ st = register False+ $ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]+ st++ out :: sig (Enabled a)+ out = mux st+ (packEnabled high $ funMap (\ x -> return (m M.! x)) ix+ , disabledS+ )+++-- prependP appends constant list (matrix) before+-- a stream of handshaken values.++prependP :: forall a c ix sig .+ ( Size ix+ , Rep a+ , Rep ix+ , Num ix+ , Clock c+ , sig ~ Signal c+ )+ => Matrix ix a+ -> Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ack) (sig Ack)+prependP m ~(inp,ackOut) = (ackIn,out)+ where+ ix :: sig ix+ ix = register 0+ $ cASE [ (fromAck ackOut, loopingIncS ix) ]+ ix++ st :: sig Bool+ st = register False+ $ cASE [ (fromAck ackOut .&&. ix .==. (maxBound :: sig ix), high) ]+ st++ ackIn :: sig Ack+ ackIn = mux st+ ( toAck low -- do not acccept anything until header has been sent+ , ackOut+ )+ out :: sig (Enabled a)+ out = mux st+ ( packEnabled high $ funMap (\ x -> return (m M.! x)) ix+ , inp+ )++---------------------------------------------------+-- These are patch order swappers : re-wiring only+{- To be finished++exp2Stack :: Patch ((a :> b) :> c) (a :> b :> c)+ ((d :> e) :> f) (d :> e :> f)+exp2Stack = forwardP (\ ((a :> b) :> c) -> (a :> b :> c)) $$+ backwardP (\ (a :> b :> c) -> ((a :> b) :> c))++con2Stack :: Patch (a :> b :> c) ((a :> b) :> c)+ (d :> e :> f) ((d :> e) :> f)+con2Stack = forwardP (\ (a :> b :> c) -> ((a :> b) :> c)) $$+ backwardP (\ ((a :> b) :> c) -> (a :> b :> c))++swapPatch :: Patch (a :> b) (b :> a)+ (c :> d) (d :> c)+swapPatch = forwardP (\ (a :> b) -> (b :> a)) $$+ backwardP (\ (b :> a) -> (a :> b))+-}+----------------------------------------------------+++data MergePlan = PriorityMerge -- ^ The first element always has priority+ | RoundRobinMerge -- ^ Turn about, can be slower++mergeP :: forall c sig a . (Clock c, sig ~ Signal c, Rep a)+ => MergePlan+ -> Patch ((sig (Enabled a)) :> (sig (Enabled a))) (sig (Enabled a))+ ((sig Ack) :> (sig Ack)) (sig Ack)++mergeP plan = fe $$ matrixMergeP plan+ where+ fe = forwardP (\ ~(b :> c) -> (matrix [b,c])) $$+ backwardP (\ ~m -> ( (m M.! (0 :: X2)) :> (m M.! (1 :: X2))))+++matrixMergeP :: forall c sig a x . (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x)+ => MergePlan+ -> Patch (Matrix x (sig (Enabled a))) (sig (Enabled a))+ (Matrix x (sig Ack)) (sig Ack)+matrixMergeP plan ~(mInp, ackOut) = (mAckInp, out)+ where+ isEs :: sig (Matrix x Bool)+ isEs = pack (fmap isEnabled mInp)++ -- Value to consider selecting.+ inpIndex :: sig x+ inpIndex = case plan of+ PriorityMerge -> cASE (zip (map isEnabled $ M.toList mInp) (map pureS [0..])) (pureS 0)+ RoundRobinMerge -> let reg = register 0 (mux ((isEs .!. reg) .&&. bitNot (fromAck ackOut))+ -- stop looking if found enable+ -- an no ack+ (loopingIncS reg,reg)) in reg++ mAckInp = forEach mInp $ \ x _inp -> toAck $ ((pureS x) .==. inpIndex) .&&. (fromAck ackOut)+ out = (pack mInp) .!. inpIndex++---------------------------------------------------------------------------+-- FabricPatch, the IO version of Patch+---------------------------------------------------------------------------++type FabricPatch fab+ lhs_in rhs_out+ lhs_out rhs_in+ = (lhs_in,rhs_in) -> fab (lhs_out,rhs_out)++patchF :: (MonadFix fab)+ => Patch a b+ c d -> FabricPatch fab a b+ c d+patchF patch inp = return (patch inp)++infixr 4 |$|+(|$|) :: (MonadFix fab)+ => FabricPatch fab a b+ d e+ -> FabricPatch fab b c+ e f+ -> FabricPatch fab a c+ d f+f1 |$| f2 = \ ~(lhs_in,rhs_in) -> do+ rec ~(lhs_out1,rhs_out1) <- f1 (lhs_in,lhs_out2)+ ~(lhs_out2,rhs_out2) <- f2 (rhs_out1,rhs_in)+ return (lhs_out1,rhs_out2)++runF :: (MonadFix fab)+ => FabricPatch fab () a+ () () -> fab a+runF p = do+ ~(_,a) <- p ((),())+ return a++buildF :: (MonadFix fab)+ => ((a,d) -> fab (c,b))+ -> FabricPatch fab a b+ c d+buildF = id+++-- | A fabric patch that passes through data and control.+emptyF :: (MonadFix fab)+ => FabricPatch+ fab a a+ b b+emptyF = patchF emptyP++infixr 3 `stackF`+-- | Given two fabric patches, tuple their data/control inputs and outputs.+stackF :: (MonadFix fab)+ => FabricPatch fab+ li1 ro1+ lo1 ri1+ -> FabricPatch fab+ li2 ro2+ lo2 ri2+ -> FabricPatch fab+ (li1 :> li2) (ro1 :> ro2)+ (lo1 :> lo2) (ri1 :> ri2)+stackF p1 p2 ~(li1 :> li2,ri1 :> ri2) = do+ (lo1,ro1) <- p1 (li1,ri1)+ (lo2,ro2) <- p2 (li2,ri2)+ return $ (lo1 :> lo2,ro1 :> ro2)++{-+f1 |$ f2 = f1 |$| fabricPatch f2+f1 $| f2 = fabricPatch f1 |$| f2+-}
+ Language/KansasLava/Protocols/ReadyBox.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,+ TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes,+ UndecidableInstances #-}++-- | This module implements an Ready protocol. In this producer/consumer model,+-- the consumer issues a Ready signal to the producer, at which time the+-- producer can drive the data input to the consumer, signaling data valid with+-- an Enable. The producer will hold the consumer data input steady until it+-- receives another Ready.+module Language.KansasLava.Protocols.ReadyBox where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Protocols.Enabled+import Language.KansasLava.Protocols.Types+import Language.KansasLava.Protocols.Patch+import Language.KansasLava.Probes+import Language.KansasLava.Utils++------------------------------------------------------------------------------------+++{- The convention with ReadyBoxn signals is+ ...+ -> (lhs_inp, rhs_inp)+ -> (lhs_out, rhs_out)++OR++ -> (lhs_inp, control_in, rhs_inp)+ -> (lhs_out, control_out, rhs_out)++-}+++-- | Take a list of shallow values and create a stream which can be sent into+-- a FIFO, respecting the write-ready flag that comes out of the FIFO.+toReadyBox :: (Rep a, Clock c, sig ~ Signal c)+ => Patch [Maybe a] (sig (Enabled a))+ () (sig Ready)+toReadyBox = toReadyBox' []++-- | A readybox that goes through a sequence of intermediate states after+-- issuing each enable, and before it looks for the next Ready.+toReadyBox' :: (Rep a, Clock c, sig ~ Signal c)+ => [Int] -- ^ list wait states after every succesful post+ -> Patch [Maybe a] (sig (Enabled a))+ () (sig Ready)+toReadyBox' pauses ~(ys,full) = ((),toS (fn ys (fromS full) pauses))+ where+-- fn xs cs ps | trace (show ("fn",take 5 ps)) False = undefined+ -- send the value *before* checking the Ready+ fn xs fs ps =+ case fs of+ (Nothing:_) -> error "toReadyBox: bad protocol state (1)"+ (Just (Ready True) : fs') ->+ case (xs,ps) of+ (x:xs',0:ps') -> x : fn xs' fs' ps' -- write it (it may be Nothing)+ (Nothing:xs',p:ps') -> Nothing : fn xs' fs' (pred p : ps')+ (_:_,p:ps') -> Nothing : fn xs fs' (pred p : ps')+ (_:_,[]) -> fn xs fs (repeat 0)+ (_,_) -> Nothing : fn xs fs' ps -- nothing to write+ (Just (Ready False) : fs') -> Nothing : fn xs fs' ps -- not ready yet+ [] -> error "toReadyBox: Ready seq should never end"+++-- | Take stream from a FIFO and return an asynchronous read-ready flag, which+-- is given back to the FIFO, and a shallow list of values.+-- I'm sure this space-leaks.+fromReadyBox :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) [Maybe a]+ (sig Ready) ()+fromReadyBox = fromReadyBox' (repeat 0)++-- | Like fromReadyBox, but which goes through a series of intermediate states+-- after receiving an enable before issuing another Ready.+fromReadyBox' :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => [Int]+ -> Patch (sig (Enabled a)) [Maybe a]+ (sig Ready) ()+fromReadyBox' ps ~(inp,_) = (toS (map fst internal), map snd internal)+ where+ internal = fn (fromS inp) ps++ -- pretty simple API+ fn :: [Maybe (Enabled a)] -> [Int] -> [(Ready,Maybe a)]+ fn xs (0:ps') = (Ready True,v) : rest+ where+ (v,rest) = case xs of+ (Nothing:_) -> error "found an unknown value in ReadyBox input"+ (Just Nothing:xs') -> (Nothing,fn xs' (0:ps')) -- nothing read yet+ (Just v':xs') -> (v',fn xs' ps')+ [] -> error "fromReadyBox: Ready sequences should never end"+ fn xs (p:ps') = (Ready False,Nothing) : fn (Prelude.tail xs) (pred p:ps')+ fn xs [] = fn xs (repeat 0)++-- | Introduces protocol-compliant delays (in the shallow embedding)+shallowReadyBoxBridge :: forall sig c a . (Rep a, Clock c, sig ~ Signal c, Show a)+ => ([Int],[Int])+ -> Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ready) (sig Ready)+shallowReadyBoxBridge (lhsF,rhsF) = patch+ where+ patch = fromReadyBox' lhsF $$ toReadyBox' rhsF++-- | 'probeReadyBoxPatch' creates a patch with a named probe, probing the data and ready+-- signals in a Ready interface. +probeReadyBoxP :: forall sig a c . ( Rep a, Clock c, sig ~ Signal c)+ => String+ -> Patch (sig (Enabled a)) (sig (Enabled a))+ (sig Ready) (sig Ready)+probeReadyBoxP probeName ~(inp, ready_in) = (ready_out, out)+ where+ (out, _) = unpack probed+ ready_out = ready_in++ probed :: sig (Enabled a, Ready)+ probed = probeS probeName $ pack (inp, ready_in)++-- A simple way of running a patch+runReadyBoxP :: forall sig c a b . (c ~ CLK, sig ~ Signal c, Rep a, Rep b)+ => Patch (sig (Enabled a)) (sig (Enabled b))+ (sig Ready) (sig Ready)+ -> [a] -> [b]+runReadyBoxP p as = [ b | Just b <- bs' ]+ where+ as' = map Just as+ bs' = runP (outputP as' $$ toReadyBox $$ globalClockP $$ p $$ fromReadyBox)++-- | A sink patch throws away its data input (generating a () data+-- output). 'sinkReadyP' uses an enabled/ready protocol.+sinkReadyP :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch (sig (Enabled a)) ()+ (sig Ready) ()+sinkReadyP ~(_, ()) = (toReady ready, ())+ where+ ready = high++-- | A source patch takes no input and generates a stream of values. It+-- corresponds to a top-level input port. 'alwaysReadyP' uses the+-- ready/enabled protocol.+alwaysReadyP :: forall a c sig . ( Rep a, Clock c, sig ~ Signal c)+ => a+ -> Patch () (sig (Enabled a))+ () (sig Ready)+alwaysReadyP baseVal ~((), ready_in) = ((), out)+ where+ out = packEnabled (fromReady ready_in) (pureS baseVal)++-- | stub, no data ever sent.+neverReadyP :: forall a c sig . (Rep a, Clock c, sig ~ Signal c)+ => Patch () (sig (Enabled a))+ () (sig Ready)+neverReadyP (_,_) = ((),disabledS)
+ Language/KansasLava/Protocols/Types.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,+ TypeSynonymInstances, FlexibleInstances, GADTs, RankNTypes,+ UndecidableInstances, TypeOperators #-}++-- | This module provides types and functions for creating and manipulating+-- control signals (ready and ack) associated with protocols. The 'Ack' signal+-- indicates that a protocol element has received data from an upstream source,+-- and the 'Ready' signal indicates that the component is prepared to accept+-- data from an upstream source.+module Language.KansasLava.Protocols.Types where++import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Utils++import Control.Monad++-- It is preferable to be sending a message that expects an Ack,+-- but to recieve a message based on your Ready signal.++------------------------------------------------------------------------------------+-- | An Ack is always in response to an incoming packet or message.+newtype Ack = Ack { unAck :: Bool }+ deriving (Eq,Ord)++instance Show Ack where+ show (Ack True) = "A"+ show (Ack False) = "~"+++-- TODO: use $(repSynonym ''Ack ''Bool)++instance Rep Ack where+ data X Ack = XAckRep { unXAckRep :: X Bool }+ type W Ack = W Bool+ -- The template for using representations+ unX = liftM Ack . unX . unXAckRep+ optX = XAckRep . optX . liftM unAck+ toRep = toRep . unXAckRep+ fromRep = XAckRep . fromRep+ repType Witness = repType (Witness :: Witness Bool)+ showRep = showRepDefault++-- | Convert a 'Bool' signal to an 'Ack' signal.+toAck :: (sig ~ Signal clk) => sig Bool -> sig Ack+toAck = coerce Ack++-- | Convert an 'Ack' to a 'Bool' signal.+fromAck :: (sig ~ Signal clk) => sig Ack -> sig Bool+fromAck = coerce unAck++------------------------------------------------------------------------------------+-- | An Ready is always in response to an incoming packet or message+newtype Ready = Ready { unReady :: Bool }+ deriving (Eq,Ord)++instance Show Ready where+ show (Ready True) = "R"+ show (Ready False) = "~"++instance Rep Ready where+ data X Ready = XReadyRep { unXReadyRep :: X Bool }+ type W Ready = W Bool+ -- The template for using representations+ unX = liftM Ready . unX . unXReadyRep+ optX = XReadyRep . optX . liftM unReady+ toRep = toRep . unXReadyRep+ fromRep = XReadyRep . fromRep+ repType Witness = repType (Witness :: Witness Bool)+ showRep = showRepDefault++-- | Convert a Bool signal to a 'Ready' signal.+toReady :: (sig ~ Signal clk) => sig Bool -> sig Ready+toReady = coerce Ready++-- | Convert a 'Ready' signal to a Bool signal.+fromReady :: (sig ~ Signal clk) => sig Ready -> sig Bool+fromReady = coerce unReady++------------------------------------------------------------------------------------------------------------------------------------------------+
+ Language/KansasLava/RTL.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE RankNTypes, GADTs, ExistentialQuantification,+ ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-}++-- | The RTL module provides a small DSL that's useful for control-oriented -- stateful -- computations.+module Language.KansasLava.RTL (+ RTL(..), -- not abstract+ Reg, -- abstract+ Cond(..), -- not abstract+ runRTL,+ reg, var,+ newReg, newArr,+ match+ ) where++import Language.KansasLava.Protocols+import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Utils+import Language.KansasLava.Probes+import Data.Sized.Matrix+import Control.Monad.ST+import Data.STRef+import Data.List as L++--import Debug.Trace++-------------------------------------------------------------------------------+-- | A register is used internally to represent a register or memory element.+data Reg s c a = Reg (Signal c a) -- output of register+ (Signal c a) -- input to register+ (STRef s [Signal c a -> Signal c a])+ (STRef s (Maybe String)) -- name for debug message+ Int+ | forall ix . (Rep ix) =>+ Arr (Signal c a)+ (Signal c ix)+ (STRef s [Signal c (Maybe (ix,a)) -> Signal c (Maybe (ix,a))])+ Int+ -- the "assignments"++-- | reg is the value of a register, as set by the start of the cycle.+reg :: Reg s c a -> Signal c a+reg (Reg iseq _ _ _ _) = iseq+reg (Arr iseq _ _ _) = iseq++-- | var is the value of a register, as will be set in the next cycle,+-- so intra-cycle changes are observed. The is simular to a *variable*+-- in VHDL.+var :: Reg s c a -> Signal c a+var (Reg _ iseq _ _ _) = iseq+var (Arr _ _ _ _) = error "can not take the var of an array"++-------------------------------------------------------------------------------++-- | A predicate (boolean) circuit. If the argument is Nothing, treat it as true.+data Pred c = Pred (Maybe (Signal c Bool))++-- | A predicate that's always true.+truePred :: Pred c+truePred = Pred Nothing++-- | Conjunction of predicates.+andPred :: Pred c -> Signal c Bool -> Pred c+andPred (Pred Nothing) c = Pred (Just c)+andPred (Pred (Just c1)) c2 = Pred (Just (c1 .&&. c2))++-- | If the first predicate is false, then return the first element of the+-- predicate. Otherwise, return the second element.+muxPred :: (Rep a) => Pred c -> (Signal c a, Signal c a) -> Signal c a+muxPred (Pred Nothing) (_,t) = t+muxPred (Pred (Just p)) (f,t) = mux p (f,t)++-------------------------------------------------------------------------------++-- | RTL Monad; s == the runST state; c is governing clock, and a is the result+data RTL s c a where+ RTL :: (Pred c -> STRef s Int -> ST s (a,[Int])) -> RTL s c a+ (:=) :: forall c b s . (Rep b) => Reg s c b -> Signal c b -> RTL s c ()+ CASE :: [Cond s c] -> RTL s c ()+ WHEN :: Signal c Bool -> RTL s c () -> RTL s c ()+ DEBUG :: forall c b s . (Rep b) => String -> Reg s c b -> RTL s c ()++-- everything except ($) bids tighter+infixr 0 :=++instance Monad (RTL s c) where+ return a = RTL $ \ _ _ -> return (a,[])+ m >>= k = RTL $ \ c u -> do (r1,f1) <- unRTL m c u+ (r2,f2) <- unRTL (k r1) c u+ return (r2,f1 ++ f2)++-- | Run the RTL monad.+runRTL :: forall c a . (Clock c) => (forall s . RTL s c a) -> a+runRTL rtl = runST (do+ u <- newSTRef 0+ (r,_) <- unRTL rtl truePred u+ return r)++-- This is where our fixed (constant) names get handled.+-- | 'Execute' a RTL computation, building a circuit.+unRTL :: RTL s c a -> Pred c -> STRef s Int -> ST s (a,[Int])+unRTL (RTL m) = m+unRTL (Reg _ _ varSt _ uq := ss) = \ c _u -> do+ modifySTRef varSt ((:) (\ r -> muxPred c (r,ss)))+ return ((), [uq])+unRTL (Arr _ ix varSt uq := ss) = \ c _u -> do+ modifySTRef varSt ((:) (\ r -> muxPred c (r,enabledS (pack (ix,ss)))))+ return ((), [uq])++unRTL (CASE alts) = \ c u -> do+ -- fix+ let conds = [ p | IF p _ <- alts ]+ -- assumes a resonable optimizer will remove this if needed+ other_p = bitNot $ foldr (.||.) low conds+ res <- sequence+ [ case alt of+ IF p m -> unRTL m (andPred c p) u+ OTHERWISE m -> unRTL m (andPred c other_p) u+ | alt <- alts+ ]+ let assignments = L.nub $ concat [ xs | (_,xs) <- res ]+-- () <- trace (show res) $ return ()+ return ((),assignments)+unRTL (DEBUG msg (Reg _ _ _ debugSt _)) = \ _c _u -> do+ writeSTRef debugSt (Just msg)+ return ((),[])+unRTL (DEBUG _msg _) = \ _c _u -> return ((),[])+unRTL (WHEN p m) = unRTL (CASE [IF p m])++-------------------------------------------------------------------------------++-- | A conditional statement.+data Cond s c+ = IF (Signal c Bool) (RTL s c ())+ | OTHERWISE (RTL s c ())++-------------------------------------------------------------------------------+-- data NewReg c a = NewReg (forall r . (IsReg r) => r c a)++-- Not quite sure why we need the NewReg indirection;+-- something to do with a limitation of ImpredicativeTypes.++-- |Declare a new register.+newReg :: forall a c s . (Clock c, Rep a) => a -> RTL s c (Reg s c a)+newReg def = RTL $ \ _ u -> do+ uq <- readSTRef u+ writeSTRef u (uq + 1)+ varSt <- newSTRef []+ debugSt <- newSTRef Nothing+ ~(regRes,variable) <- unsafeInterleaveST $ do+ assigns <- readSTRef varSt+ debugs <- readSTRef debugSt+ let v_old = register def v_new+ v_new = foldr (.) id (reverse assigns) v_old+ v_old' = case debugs of+ Nothing -> v_old+ Just msg -> probeS msg v_old+ return (v_old',v_new)+ return (Reg regRes variable varSt debugSt uq,[])++-- | Declare an array. Arrays support partual updates.+newArr :: forall a c ix s . (Size ix, Clock c, Rep a, Num ix, Rep ix) => Witness ix -> RTL s c (Signal c ix -> Reg s c a)+newArr Witness = RTL $ \ _ u -> do+ uq <- readSTRef u+ writeSTRef u (uq + 1)+ varSt <- newSTRef []+ proj <- unsafeInterleaveST $ do+ assigns <- readSTRef varSt+ let ass = foldr (.) id (reverse assigns) (pureS Nothing)+ let look ix = writeMemory (ass :: Signal c (Maybe (ix,a)))+ `asyncRead` ix+ return look+ return (\ ix -> Arr (proj ix) ix varSt uq, [])++--assign :: Reg s c (Matrix ix a) -> Signal c ix -> Reg s c a+--assign (Reg seq var uq) = Arr++-------------------------------------------------------------------------------++-- | match checks for a enabled value, and if so, executes the given RTL in context,+-- by constructing the correct 'Cond'-itional.+match :: (Rep a) => Signal c (Enabled a) -> (Signal c a -> RTL s c ()) -> Cond s c+match inp fn = IF (isEnabled inp) (fn (enabledVal inp))+-- To consider: This is almost a bind operator?+++-- debug :: (Rep a,Clock c) => String -> Reg s c a -> RTL
+ Language/KansasLava/Rep.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE TypeFamilies, ExistentialQuantification, FlexibleInstances, UndecidableInstances, FlexibleContexts, DeriveDataTypeable,+ ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies,ParallelListComp, EmptyDataDecls, TypeSynonymInstances, TypeOperators, TemplateHaskell #-}+-- | KansasLava is designed for generating hardware circuits. This module+-- provides a 'Rep' class that allows us to model, in the shallow embedding of+-- KL, two important features of hardware signals. First, all signals must have+-- some static width, as they will be synthsized to a collection of hardware+-- wires. Second, a value represented by a signal may be unknown, in part or in+-- whole.+module Language.KansasLava.Rep + ( module Language.KansasLava.Rep+ , module Language.KansasLava.Rep.TH+ , module Language.KansasLava.Rep.Class+ ) where++import Language.KansasLava.Types+import Control.Monad (liftM)+import Data.Sized.Arith+import Data.Sized.Ix+import Data.Sized.Matrix hiding (S)+import qualified Data.Sized.Matrix as M+import Data.Sized.Unsigned as U+import Data.Sized.Signed as S+import Data.Word+import Data.Bits++--import qualified Data.Maybe as Maybe+import Data.Traversable(sequenceA)+import qualified Data.Sized.Sampled as Sampled++import Language.KansasLava.Rep.TH+import Language.KansasLava.Rep.Class+++-- | Check to see if all bits in a bitvector (represented as a Matrix) are+-- valid. Returns Nothing if any of the bits are unknown.+allOkayRep :: (Size w) => Matrix w (X Bool) -> Maybe (Matrix w Bool)+allOkayRep m = sequenceA $ fmap prj m+ where prj (XBool Nothing) = Nothing+ prj (XBool (Just v)) = Just v+++------------------------------------------------------------------------------------++instance Rep Bool where+ type W Bool = X1+ data X Bool = XBool (Maybe Bool)+ optX (Just b) = XBool $ return b+ optX Nothing = XBool $ fail "Wire Bool"+ unX (XBool (Just v)) = return v+ unX (XBool Nothing) = fail "Wire Bool"+ repType _ = B+ toRep (XBool v) = RepValue [v]+ fromRep (RepValue [v]) = XBool v+ fromRep rep = error ("size error for Bool : " ++ show (Prelude.length $ unRepValue rep) ++ " " ++ show rep)+ showRep (XBool Nothing) = "?"+ showRep (XBool (Just True)) = "high"+ showRep (XBool (Just False)) = "low"++$(repIntegral ''Int (S $ bitSize $ (error "witness" :: Int)))++$(repIntegral ''Word8 (U 8))+$(repIntegral ''Word32 (U 32))++instance Rep () where+ type W () = X0+ data X () = XUnit (Maybe ())+ optX (Just b) = XUnit $ return b+ optX Nothing = XUnit $ fail "Wire ()"+ unX (XUnit (Just v)) = return v+ unX (XUnit Nothing) = fail "Wire ()"+ repType _ = V 1 -- should really be V 0 TODO+ toRep _ = RepValue []+ fromRep _ = XUnit $ return ()+ showRep _ = "()"++-- | Integers are unbounded in size. We use the type 'IntegerWidth' as the+-- associated type representing this size in the instance of Rep for Integers.+data IntegerWidth = IntegerWidth++instance Rep Integer where+ type W Integer = IntegerWidth+ data X Integer = XInteger Integer -- No fail/unknown value+ optX (Just b) = XInteger b+ optX Nothing = XInteger $ error "Generic failed in optX"+ unX (XInteger a) = return a+ repType _ = GenericTy+ toRep = error "can not turn a Generic to a Rep"+ fromRep = error "can not turn a Rep to a Generic"+ showRep (XInteger v) = show v++-------------------------------------------------------------------------------------+-- Now the containers++-- TODO: fix this to use :> as the basic internal type.++instance (Rep a, Rep b) => Rep (a :> b) where+ type W (a :> b) = ADD (W a) (W b)+ data X (a :> b) = XCell (X a, X b)+ optX (Just (a :> b)) = XCell (pureX a, pureX b)+ optX Nothing = XCell (optX (Nothing :: Maybe a), optX (Nothing :: Maybe b))+ unX (XCell (a,b)) = do x <- unX a+ y <- unX b+ return (x :> y)++ repType Witness = TupleTy [repType (Witness :: Witness a), repType (Witness :: Witness b)]++ toRep (XCell (a,b)) = RepValue (avals ++ bvals)+ where (RepValue avals) = toRep a+ (RepValue bvals) = toRep b+ fromRep (RepValue vs) = XCell ( fromRep (RepValue (take size_a vs))+ , fromRep (RepValue (drop size_a vs))+ )+ where size_a = typeWidth (repType (Witness :: Witness a))+ showRep (XCell (a,b)) = showRep a ++ " :> " ++ showRep b+++instance (Rep a, Rep b) => Rep (a,b) where+ type W (a,b) = ADD (W a) (W b)+ data X (a,b) = XTuple (X a, X b)+ optX (Just (a,b)) = XTuple (pureX a, pureX b)+ optX Nothing = XTuple (optX (Nothing :: Maybe a), optX (Nothing :: Maybe b))+ unX (XTuple (a,b)) = do x <- unX a+ y <- unX b+ return (x,y)++ repType Witness = TupleTy [repType (Witness :: Witness a), repType (Witness :: Witness b)]++ toRep (XTuple (a,b)) = RepValue (avals ++ bvals)+ where (RepValue avals) = toRep a+ (RepValue bvals) = toRep b+ fromRep (RepValue vs) = XTuple ( fromRep (RepValue (take size_a vs))+ , fromRep (RepValue (drop size_a vs))+ )+ where size_a = typeWidth (repType (Witness :: Witness a))+ showRep (XTuple (a,b)) = "(" ++ showRep a ++ "," ++ showRep b ++ ")"++instance (Rep a, Rep b, Rep c) => Rep (a,b,c) where+ type W (a,b,c) = ADD (W a) (ADD (W b) (W c))+ data X (a,b,c) = XTriple (X a, X b, X c)+ optX (Just (a,b,c)) = XTriple (pureX a, pureX b,pureX c)+ optX Nothing = XTriple ( optX (Nothing :: Maybe a),+ optX (Nothing :: Maybe b),+ optX (Nothing :: Maybe c) )+ unX (XTriple (a,b,c))+ = do x <- unX a+ y <- unX b+ z <- unX c+ return (x,y,z)++ repType Witness = TupleTy [repType (Witness :: Witness a), repType (Witness :: Witness b),repType (Witness :: Witness c)]+ toRep (XTriple (a,b,c)) = RepValue (avals ++ bvals ++ cvals)+ where (RepValue avals) = toRep a+ (RepValue bvals) = toRep b+ (RepValue cvals) = toRep c+ fromRep (RepValue vs) = XTriple ( fromRep (RepValue (take size_a vs))+ , fromRep (RepValue (take size_b (drop size_a vs)))+ , fromRep (RepValue (drop (size_a + size_b) vs))+ )+ where size_a = typeWidth (repType (Witness :: Witness a))+ size_b = typeWidth (repType (Witness :: Witness b))+ showRep (XTriple (a,b,c)) = "(" ++ showRep a +++ "," ++ showRep b +++ "," ++ showRep c ++ ")"++instance (Rep a) => Rep (Maybe a) where+ type W (Maybe a) = ADD (W a) X1+ -- not completely sure about this representation+ data X (Maybe a) = XMaybe (X Bool, X a)+ optX b = XMaybe ( case b of+ Nothing -> optX (Nothing :: Maybe Bool)+ Just Nothing -> optX (Just False :: Maybe Bool)+ Just (Just {}) -> optX (Just True :: Maybe Bool)+ , case b of+ Nothing -> optX (Nothing :: Maybe a)+ Just Nothing -> optX (Nothing :: Maybe a)+ Just (Just a) -> optX (Just a :: Maybe a)+ )+ unX (XMaybe (a,b)) = case unX a :: Maybe Bool of+ Nothing -> Nothing+ Just True -> case unX b of+ Nothing -> Nothing + Just v -> Just (Just v)+ Just False -> Just Nothing+ repType _ = TupleTy [ B, repType (Witness :: Witness a)]++ toRep (XMaybe (a,b)) = RepValue (avals ++ bvals)+ where (RepValue avals) = toRep a+ (RepValue bvals) = toRep b+ fromRep (RepValue vs) = XMaybe + ( fromRep (RepValue (take 1 vs))+ , fromRep (RepValue (drop 1 vs))+ )+ showRep (XMaybe (XBool Nothing,_a)) = "?"+ showRep (XMaybe (XBool (Just True),a)) = "Just " ++ showRep a+ showRep (XMaybe (XBool (Just False),_)) = "Nothing"++instance (Size ix, Rep a) => Rep (Matrix ix a) where+ type W (Matrix ix a) = MUL ix (W a)+ data X (Matrix ix a) = XMatrix (Matrix ix (X a))+ optX (Just m) = XMatrix $ fmap (optX . Just) m+ optX Nothing = XMatrix $ forAll $ \ _ -> optX (Nothing :: Maybe a)+ unX (XMatrix m) = liftM matrix $ mapM (\ i -> unX (m ! i)) (indices m)+ repType Witness = MatrixTy (size (error "witness" :: ix)) (repType (Witness :: Witness a))+ toRep (XMatrix m) = RepValue (concatMap (unRepValue . toRep) $ M.toList m)+ fromRep (RepValue xs) = XMatrix $ M.matrix $ fmap (fromRep . RepValue) $ unconcat xs+ where unconcat [] = []+ unconcat ys = take len ys : unconcat (drop len ys)++ len = Prelude.length xs `div` size (error "witness" :: ix)++instance (Size ix) => Rep (Unsigned ix) where+ type W (Unsigned ix) = ix+ data X (Unsigned ix) = XUnsigned (Maybe (Unsigned ix))+ optX (Just b) = XUnsigned $ return b+ optX Nothing = XUnsigned $ fail "Wire Int"+ unX (XUnsigned (Just a)) = return a+ unX (XUnsigned Nothing) = fail "Wire Int"+ repType _ = U (size (error "Wire/Unsigned" :: ix))+ toRep = toRepFromIntegral+ fromRep = fromRepToIntegral+ showRep = showRepDefault++instance (Size ix) => Rep (Signed ix) where+ type W (Signed ix) = ix+ data X (Signed ix) = XSigned (Maybe (Signed ix))+ optX (Just b) = XSigned $ return b+ optX Nothing = XSigned $ fail "Wire Int"+ unX (XSigned (Just a)) = return a+ unX (XSigned Nothing) = fail "Wire Int"+ repType _ = S (size (error "Wire/Signed" :: ix))+ toRep = toRepFromIntegral+ fromRep = fromRepToIntegral+ showRep = showRepDefault++-----------------------------------------------------------------------------+-- The grandfather of them all, functions.++instance (Size ix, Rep a, Rep ix) => Rep (ix -> a) where+ type W (ix -> a) = MUL ix (W a)+ data X (ix -> a) = XFunction (ix -> X a)++ optX (Just f) = XFunction $ \ ix -> optX (Just (f ix))+ optX Nothing = XFunction $ const $ unknownX++ unX (XFunction f) = return (\ a -> + let fromJust' (Just x) = x+ fromJust' _ = error $ show ("X",repType (Witness :: Witness (ix -> a)), showRep (optX (Just a) :: X ix))+ in (fromJust' . unX . f) a)++ repType Witness = MatrixTy (size (error "witness" :: ix)) (repType (Witness :: Witness a))++ -- reuse the matrix encodings here+ -- TODO: work out how to remove the Size ix constraint,+ -- and use Rep ix somehow instead.+ toRep (XFunction f) = toRep (XMatrix $ M.forAll f)+ fromRep (RepValue xs) = XFunction $ \ ix ->+ case fromRep (RepValue xs) of+ XMatrix m -> m M.! ix++{-+infixl 4 `apX`++-- The applicative functor style 'ap'.+apX :: (Rep a, Rep b) => X (a -> b) -> X a -> X b+apX (XFunction f) a = f a++-- The apX-1 function. Useful when building applicative functor style things+-- on top of 'X'.+unapX :: (Rep a, Rep b) => (X a -> X b) -> X (a -> b) +unapX f = XFunction f+-} ++-----------------------------------------------------------------------------++-- | Calculate the base-2 logrithim of a integral value.+log2 :: (Integral a) => a -> a+log2 0 = 0+log2 1 = 1+log2 n = log2 (n `div` 2) + 1++-- Perhaps not, because what does X0 really mean over a wire, vs X1.+instance Rep X0 where+ type W X0 = X0+ data X X0 = X0'+ optX _ = X0'+ unX X0' = return X0+ repType _ = V 0+ toRep = toRepFromIntegral+ fromRep = fromRepToIntegral+ showRep = showRepDefault++instance (Integral x, Size x) => Rep (X0_ x) where+ type W (X0_ x) = LOG (SUB (X0_ x) X1)+ data X (X0_ x) = XX0 (Maybe (X0_ x))+ optX (Just x) = XX0 $ return x+ optX Nothing = XX0 $ fail "X0_"+ unX (XX0 (Just a)) = return a+ unX (XX0 Nothing) = fail "X0_"+ repType _ = U (log2 (size (error "repType" :: X0_ x) - 1))+ toRep = toRepFromIntegral+ fromRep = sizedFromRepToIntegral+ showRep = showRepDefault++instance (Integral x, Size x) => Rep (X1_ x) where+ type W (X1_ x) = LOG (SUB (X1_ x) X1)+ data X (X1_ x) = XX1 (Maybe (X1_ x))+ optX (Just x) = XX1 $ return x+ optX Nothing = XX1 $ fail "X1_"+ unX (XX1 (Just a)) = return a+ unX (XX1 Nothing) = fail "X1_"+ repType _ = U (log2 (size (error "repType" :: X1_ x) - 1))+ toRep = toRepFromIntegral+ fromRep = sizedFromRepToIntegral+ showRep = showRepDefault++-- | This is a version of fromRepToIntegral that+-- check to see if the result is inside the size bounds.+sizedFromRepToIntegral :: forall w . (Rep w, Integral w, Size w) => RepValue -> X w+sizedFromRepToIntegral w+ | val_integer >= toInteger (size (error "witness" :: w)) = unknownX+ | otherwise = val+ where+ val_integer :: Integer+ val_integer = fromRepToInteger w++ val :: X w+ val = fromRepToIntegral w++-----------------------------------------------------------------++instance (Enum ix, Size m, Size ix) => Rep (Sampled.Sampled m ix) where+ type W (Sampled.Sampled m ix) = ix+ data X (Sampled.Sampled m ix) = XSampled (Maybe (Sampled.Sampled m ix))+ optX (Just b) = XSampled $ return b+ optX Nothing = XSampled $ fail "Wire Sampled"+ unX (XSampled (Just a)) = return a+ unX (XSampled Nothing) = fail "Wire Sampled"+ repType _ = SampledTy (size (error "witness" :: m)) (size (error "witness" :: ix))+ toRep (XSampled Nothing) = unknownRepValue (Witness :: Witness (Sampled.Sampled m ix))+ toRep (XSampled (Just a)) = RepValue $ fmap Just $ M.toList $ Sampled.toMatrix a+ fromRep r = optX (liftM (Sampled.fromMatrix . M.fromList) $ getValidRepValue r)+ showRep = showRepDefault+
+ Language/KansasLava/Rep/Class.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TypeFamilies, ExistentialQuantification, FlexibleInstances, UndecidableInstances, FlexibleContexts, DeriveDataTypeable,+ ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies,ParallelListComp, TypeSynonymInstances, TypeOperators #-}+-- | KansasLava is designed for generating hardware circuits. This module+-- provides a 'Rep' class that allows us to model, in the shallow embedding of+-- KL, two important features of hardware signals. First, all signals must have+-- some static width, as they will be synthsized to a collection of hardware+-- wires. Second, a value represented by a signal may be unknown, in part or in+-- whole.+module Language.KansasLava.Rep.Class where++import Language.KansasLava.Types+import Control.Monad (liftM)+import Data.Sized.Ix+import qualified Data.Map as Map++-- | A 'Rep a' is an 'a' value that we 'Rep'resent, aka we can push it over a+-- wire. The general idea is that instances of Rep should have a width (for the+-- corresponding bitvector representation) and that Rep instances should be able+-- to represent the "unknown" -- X -- value. For example, Bools can be+-- represented with one bit, and the inclusion of the unknown X value+-- corresponds to three-valued logic.+class {- (Size (W w)) => -} Rep w where+ -- | the width of the represented value, as a type-level number.+ type W w++ -- | X are lifted inputs to this wire.+ data X w++ -- | check for bad things.+ unX :: X w -> Maybe w++ -- | and, put the good or bad things back.+ optX :: Maybe w -> X w++ -- | convert to binary (rep) format+ toRep :: X w -> RepValue++ -- | convert from binary (rep) format+ fromRep :: RepValue -> X w++ -- | Each wire has a known type.+ repType :: Witness w -> Type++ -- show the value (in its Haskell form, default is the bits)+ showRep :: X w -> String+ showRep x = showRepValue (repType (Witness :: Witness w)) (toRep x)++-- | 'Bitrep' is list of values, and their bitwise representation.+-- It is used to derive (via Template Haskell) the Rep for user Haskell datatypes.+class (Size (W a), Eq a, Rep a) => BitRep a where+ bitRep :: [(a, BitPat (W a))]+++-- | Given a witness of a representable type, generate all (2^n) possible values of that type.+allReps :: (Rep w) => Witness w -> [RepValue]+allReps w = [ RepValue (fmap Just count) | count <- counts n ]+ where+ n = repWidth w+ counts :: Int -> [[Bool]]+ counts 0 = [[]]+ counts num = [ x : xs | xs <- counts (num-1), x <- [False,True] ]++-- | Figure out the width in bits of a type.+repWidth :: (Rep w) => Witness w -> Int+repWidth w = typeWidth (repType w)+++-- | unknownRepValue returns a RepValue that is completely filled with 'X'.+unknownRepValue :: (Rep w) => Witness w -> RepValue+unknownRepValue w = RepValue [ Nothing | _ <- [1..repWidth w]]++-- | pureX lifts a value to a (known) representable value.+pureX :: (Rep w) => w -> X w+pureX = optX . Just++-- | unknownX is an unknown value of every representable type.+unknownX :: forall w . (Rep w) => X w+unknownX = optX (Nothing :: Maybe w)++-- | liftX converts a function over values to a function over possibly unknown values.+liftX :: (Rep a, Rep b) => (a -> b) -> X a -> X b+liftX f = optX . liftM f . unX++++-- | showRepDefault will print a Representable value, with "?" for unknown.+-- This is not wired into the class because of the extra 'Show' requirement.+showRepDefault :: forall w. (Show w, Rep w) => X w -> String+showRepDefault v = case unX v :: Maybe w of+ Nothing -> "?"+ Just v' -> show v'++-- | Convert an integral value to a RepValue -- its bitvector representation.+toRepFromIntegral :: forall v . (Rep v, Integral v) => X v -> RepValue+toRepFromIntegral v = case unX v :: Maybe v of+ Nothing -> unknownRepValue (Witness :: Witness v)+ Just v' -> RepValue+ $ take (repWidth (Witness :: Witness v))+ $ map (Just . odd)+ $ iterate (`div` (2::Integer))+ $ fromIntegral v'+-- | Convert a RepValue representing an integral value to a representable value+-- of that integral type.+fromRepToIntegral :: forall v . (Rep v, Integral v) => RepValue -> X v+fromRepToIntegral r =+ optX (fmap (\ xs ->+ sum [ n+ | (n,b) <- zip (iterate (* 2) 1)+ xs+ , b+ ])+ (getValidRepValue r) :: Maybe v)++-- | fromRepToInteger always a positve number, unknowns defin+fromRepToInteger :: RepValue -> Integer+fromRepToInteger (RepValue xs) =+ sum [ n+ | (n,b) <- zip (iterate (* 2) 1)+ xs+ , case b of+ Nothing -> False+ Just True -> True+ Just False -> False+ ]+++-- | Compare a golden value with a generated value.+cmpRep :: (Rep a) => X a -> X a -> Bool+cmpRep g v = toRep g `cmpRepValue` toRep v++-------------------------------------------------------------------++-- | Helper for generating the bit pattern mappings.+bitRepEnum :: (Rep a, Enum a, Bounded a, Size (W a)) => [(a,BitPat (W a))]+bitRepEnum = map (\ a -> (a,fromIntegral (fromEnum a))) [minBound .. maxBound]++{-# INLINE bitRepToRep #-}+bitRepToRep :: forall w . (BitRep w, Ord w) => X w -> RepValue+bitRepToRep = bitRepToRep' (Map.fromList $ map (\(a,b) -> (b,a)) $ Map.toList bitRepMap)++bitRepToRep' :: forall w . (BitRep w, Ord w) => Map.Map w RepValue -> X w -> RepValue+bitRepToRep' mp w =+ case unX w of+ Nothing -> unknownRepValue (Witness :: Witness w)+ Just val -> + case Map.lookup val mp of+ Nothing -> unknownRepValue (Witness :: Witness w)+ Just pat -> pat -- chooseRepValue $ bitPatToRepValue pat++{-# INLINE bitRepFromRep #-}+bitRepFromRep :: forall w . (Ord w, BitRep w) => RepValue -> X w+bitRepFromRep = bitRepFromRep' bitRepMap++bitRepFromRep' :: forall w . (Ord w, BitRep w) => Map.Map RepValue w -> RepValue -> X w+bitRepFromRep' mp rep = optX $ Map.lookup rep mp++bitRepMap :: forall w . (BitRep w, Ord w) => Map.Map RepValue w+bitRepMap = Map.fromList+ [ (rep,a)+ | (a,BitPat repX) <- bitRep+ , rep <- expandBitRep repX+ ]++expandBitRep :: RepValue -> [RepValue]+expandBitRep (RepValue bs) = map RepValue $ expand bs+ where+ expand [] = [[]] + expand (x:xs) = [ (Just y:ys) + | ys <- expand xs+ , y <- case x of+ Nothing -> [False,True]+ Just v -> [v]+ ]++ + +
+ Language/KansasLava/Rep/TH.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE TemplateHaskell, TypeFamilies #-}++module Language.KansasLava.Rep.TH where+++import Language.Haskell.TH+import Language.Haskell.TH.Syntax as S++import Language.KansasLava.Types as KLT+import Language.KansasLava.Rep.Class++-- You would think that you could go from Name to Kansas Lava type,+-- but this breaks the staging in Template Haskell.+repIntegral :: Name -> KLT.Type -> Q [Dec]+repIntegral tyName tyType = do+ x <- newName "x"+ sequence [ instanceD + (return [])+ (appT (conT ''Rep) (conT tyName))+ [ tySynInstD ''W [conT tyName] (conT (mkName xSize))+ , dataInstD (return [])+ ''X [conT tyName]+ [ normalC xConsName+ [ strictType notStrict (appT (conT ''Maybe) (conT tyName)) ]+ ]+ []+ , funD 'optX+ [clause [varP x] + (normalB+ (appE (conE xConsName)+ (varE x)))+ []+ ]+ , funD 'unX+ [clause [conP xConsName [varP x]] + (normalB+ (varE x))+ []+ ]+ , funD 'repType+ [clause [wildP]+ (normalB [| tyType |])+ []+ ]+ , valD (varP 'toRep)+ (normalB (varE 'toRepFromIntegral))+ []+ , valD (varP 'fromRep)+ (normalB (varE 'fromRepToIntegral))+ []+ , valD (varP 'showRep)+ (normalB (varE 'showRepDefault))+ []+ ] + ]+ where+ strName = nameBase tyName+ xConsName = mkName ("X" ++ strName)+ xSize = "X" ++ show (typeWidth tyType)++-- You would think that you could go from Name to Kansas Lava type,+-- but this breaks the staging in Template Haskell.+repBitRep :: Name -> Int -> Q [Dec]+repBitRep tyName width = do -- tyType = do+ x <- newName "x"+ sequence [ instanceD + (return [])+ (appT (conT ''Rep) (conT tyName))+ [ tySynInstD ''W [conT tyName] (conT (mkName xSize))+ , dataInstD (return [])+ ''X [conT tyName]+ [ normalC xConsName+ [ strictType notStrict (appT (conT ''Maybe) (conT tyName)) ]+ ]+ []+ , funD 'optX+ [clause [varP x] + (normalB+ (appE (conE xConsName)+ (varE x)))+ []+ ]+ , funD 'unX+ [clause [conP xConsName [varP x]] + (normalB+ (varE x))+ []+ ]+ , funD 'repType+ [clause [wildP]+ (normalB (appE (conE 'V)+ (litE (integerL (fromIntegral width)))+ ))+ []+ ]+ , valD (varP 'toRep)+ (normalB (varE 'bitRepToRep))+ []+ , valD (varP 'fromRep)+ (normalB (varE 'bitRepFromRep))+ []+ , valD (varP 'showRep)+ (normalB (varE 'showRepDefault))+ []+ ] + ]+ where+ strName = nameBase tyName+ xConsName = mkName ("X" ++ strName)+ xSize = "X" ++ show width+-- (typeWidth tyType)+++instance S.Lift KLT.Type where+ lift (S n) = conE 'S `appE` (lift n)+ lift (U n) = conE 'U `appE` (lift n)+ lift other = error ("lift " ++ show other)+{-++repSize :: Name -> Q Exp+repSize tyName = appE (varE (mkName "Data.Bits.bitSize"))+ (litE (integerL 0) `sigE` (conT tyName))++repSigned :: Name -> Q Exp+repSigned tyName = appE (varE (mkName "Data.Bits.isSigned"))+ (litE (integerL 0) `sigE` (conT tyName))+++-}
+ Language/KansasLava/Signal.hs view
@@ -0,0 +1,443 @@+{-# LANGUAGE TypeFamilies, ExistentialQuantification,+ FlexibleInstances, UndecidableInstances, FlexibleContexts,+ ScopedTypeVariables, MultiParamTypeClasses #-}++-- | The Signal module serves as a representation for the combined shallow and+-- deep embeddings of sequential circuits. The shallow portion is reprented as a+-- stream, the deep portion as a (typed) entity. To allow for multiple clock+-- domains, the Signal type includes an extra type parameter. The type alias 'Seq'+-- is for sequential logic in some implicit global clock domain.+module Language.KansasLava.Signal where++import Control.Applicative+import Control.Monad (liftM, liftM2, liftM3)+import Data.List as List+import Data.Bits++import Data.Sized.Ix+import Data.Sized.Matrix as M++import Language.KansasLava.Stream (Stream(Cons))+import Language.KansasLava.Rep+import qualified Language.KansasLava.Stream as S+import Language.KansasLava.Types++-----------------------------------------------------------------------------------------------++-- | These are sequences of values over time.+-- We assume edge triggered logic (checked at (typically) rising edge of clock)+-- This clock is assumed known, based on who is consuming the list.+-- Right now, it is global, but we think we can support multiple clocks with a bit of work.+data Signal (c :: *) a = Signal (S.Stream (X a)) (D a)++-- | Signal in some implicit clock domain.+type Seq a = Signal CLK a++-- | Extract the shallow portion of a 'Signal'.+shallowS :: Signal c a -> S.Stream (X a)+shallowS (Signal a _) = a++-- | Extract the deep portion of a 'Signal'.+deepS :: Signal c a -> D a+deepS (Signal _ d) = d++deepMapS :: (D a -> D a) -> Signal c a -> Signal c a+deepMapS f (Signal a d) = (Signal a (f d))++shallowMapS :: (S.Stream (X a) -> S.Stream (X a)) -> Signal c a -> Signal c a+shallowMapS f (Signal a d) = (Signal (f a) d)++-- | A pure 'Signal'.+pureS :: (Rep a) => a -> Signal i a+pureS a = Signal (pure (pureX a)) (D $ Lit $ toRep $ pureX a)++-- | A 'Signal' witness identity function. Useful when typing things.+witnessS :: (Rep a) => Witness a -> Signal i a -> Signal i a+witnessS (Witness) = id++-- | Inject a deep value into a Signal. The shallow portion of the Signal will be an+-- error, if it is every used.+mkDeepS :: D a -> Signal c a+mkDeepS = Signal (error "incorrect use of shallow Signal")++-- | Inject a shallow value into a Signal. The deep portion of the Signal will be an+-- Error if it is ever used.+mkShallowS :: (Clock c) => S.Stream (X a) -> Signal c a+mkShallowS s = Signal s (D $ Error "incorrect use of deep Signal")++-- | Create a Signal with undefined for both the deep and shallow elements.+undefinedS :: forall a sig clk . (Rep a, sig ~ Signal clk) => sig a+undefinedS = Signal (pure $ (unknownX :: X a))+ (D $ Lit $ toRep (unknownX :: X a))++-- | Attach a comment to a 'Signal'.+commentS :: forall a sig clk . (Rep a, sig ~ Signal clk) => String -> sig a -> sig a+commentS msg = idS (Comment [msg])++-----------------------------------------------------------------------+-- primitive builders++-- | 'idS' create an identity function, with a given 'Id' tag.++idS :: forall a sig clk . (Rep a, sig ~ Signal clk) => Id -> sig a -> sig a+idS id' (Signal a ae) = Signal a $ D $ Port "o0" $ E + $ Entity id'+ [("o0",repType (Witness :: Witness a))]+ [("i0",repType (Witness :: Witness a),unD $ ae)]++-- | create a zero-arity Signal value from an 'X' value.+primXS :: (Rep a) => X a -> String -> Signal i a+primXS a nm = Signal (pure a) (entityD nm)++-- | create an arity-1 Signal function from an 'X' function.+primXS1 :: forall a b i . (Rep a, Rep b) => (X a -> X b) -> String -> Signal i a -> Signal i b+primXS1 f nm (Signal a1 ae1) = Signal (fmap f a1) (entityD1 nm ae1)++-- | create an arity-2 Signal function from an 'X' function.+primXS2 :: forall a b c i . (Rep a, Rep b, Rep c) => (X a -> X b -> X c) -> String -> Signal i a -> Signal i b -> Signal i c+primXS2 f nm (Signal a1 ae1) (Signal a2 ae2) + = Signal (S.zipWith f a1 a2) + (entityD2 nm ae1 ae2)++-- | create an arity-3 Signal function from an 'X' function.+primXS3 :: forall a b c d i . (Rep a, Rep b, Rep c, Rep d)+ => (X a -> X b -> X c -> X d) -> String -> Signal i a -> Signal i b -> Signal i c -> Signal i d+primXS3 f nm (Signal a1 ae1) (Signal a2 ae2) (Signal a3 ae3) = Signal (S.zipWith3 f a1 a2 a3)+ (entityD3 nm ae1 ae2 ae3)++-- | create a zero-arity Signal value from a value.+primS :: (Rep a) => a -> String -> Signal i a+primS a nm = primXS (pureX a) nm++-- | create an arity-1 Signal function from a function.+primS1 :: (Rep a, Rep b) => (a -> b) -> String -> Signal i a -> Signal i b+primS1 f nm = primXS1 (\ a -> optX $ liftM f (unX a)) nm++-- | create an arity-2 Signal function from a function.+primS2 :: (Rep a, Rep b, Rep c) => (a -> b -> c) -> String -> Signal i a -> Signal i b -> Signal i c+primS2 f nm = primXS2 (\ a b -> optX $ liftM2 f (unX a) (unX b)) nm++-- | create an arity-3 Signal function from a function.+primS3 :: (Rep a, Rep b, Rep c, Rep d) => (a -> b -> c -> d) -> String -> Signal i a -> Signal i b -> Signal i c -> Signal i d+primS3 f nm = primXS3 (\ a b c -> optX $ liftM3 f (unX a) (unX b) (unX c)) nm++---------------------------------------------------------------------------------++instance (Rep a) => Show (Signal c a) where+ show (Signal vs _) = show' "" vs+ where+ show' end (Cons a opt_as) = showRep a ++ maybe end (\ as -> " | " ++ show' " ." as) opt_as++instance (Rep a, Eq a) => Eq (Signal c a) where+ -- Silly question; never True; can be False.+ (Signal _ _) == (Signal _ _) = error "undefined: Eq over a Signal"++instance (Num a, Rep a) => Num (Signal i a) where+ s1 + s2 = primS2 (+) "+" s1 s2+ s1 - s2 = primS2 (-) "-" s1 s2+ s1 * s2 = primS2 (*) "*" s1 s2+ negate s1 = primS1 (negate) "negate" s1+ abs s1 = primS1 (abs) "abs" s1+ signum s1 = primS1 (signum) "signum" s1+ fromInteger n = pureS (fromInteger n)++instance (Bounded a, Rep a) => Bounded (Signal i a) where+ minBound = pureS $ minBound+ maxBound = pureS $ maxBound++instance (Show a, Bits a, Rep a) => Bits (Signal i a) where+ s1 .&. s2 = primS2 (.&.) "and2" s1 s2+ s1 .|. s2 = primS2 (.|.) "or2" s1 s2+ s1 `xor` s2 = primS2 (xor) "xor2" s1 s2+ s1 `shiftL` n = primS2 (shiftL) ("shiftL" ++ if isSigned s1 then "A" else "") s1 (pureS n)+ s1 `shiftR` n = primS2 (shiftR) ("shiftR" ++ if isSigned s1 then "A" else "") s1 (pureS n)+ s1 `rotateL` n = primS2 (rotateL) "rotateL" s1 (pureS n)+ s1 `rotateR` n = primS2 (rotateR) "rotateR" s1 (pureS n)+ complement s = primS1 (complement) "complement" s+ bitSize s = typeWidth (typeOfS s)+ isSigned s = isTypeSigned (typeOfS s)++instance (Eq a, Show a, Fractional a, Rep a) => Fractional (Signal i a) where+ s1 / s2 = primS2 (/) "/" s1 s2+ recip s1 = primS1 (recip) "recip" s1+ -- This should just fold down to the raw bits.+ fromRational r = pureS (fromRational r :: a)++instance (Rep a, Enum a) => Enum (Signal i a) where+ toEnum = error "toEnum not supported"+ fromEnum = error "fromEnum not supported"++instance (Ord a, Rep a) => Ord (Signal i a) where+ compare _ _ = error "compare not supported for Comb"+ (<) _ _ = error "(<) not supported for Comb"+ (>=) _ _ = error "(>=) not supported for Comb"+ (>) _ _ = error "(>) not supported for Comb"+ (<=)_ _ = error "(<=) not supported for Comb"+ s1 `max` s2 = primS2 max "max" s1 s2+ s1 `min` s2 = primS2 max "min" s1 s2++instance (Rep a, Real a) => Real (Signal i a) where+ toRational = error "toRational not supported for Comb"++instance (Rep a, Integral a) => Integral (Signal i a) where+ quot num dom = primS2 quot "quot" num dom+ rem num dom = primS2 rem "rem" num dom+ div num dom = primS2 div "div" num dom+ mod num dom = primS2 mod "mod" num dom++ quotRem num dom = (quot num dom, rem num dom)+ divMod num dom = (div num dom, mod num dom)+ toInteger = error "toInteger (Signal {})"++----------------------------------------------------------------------------------------------------++-- Small DSL's for declaring signals++-- | Convert a list of values into a Signal. The shallow portion of the resulting+-- Signal will begin with the input list, then an infinite stream of X unknowns.+toS :: (Clock c, Rep a) => [a] -> Signal c a+toS = toS' . map Just++-- | Convert a list of values into a Signal. The input list is wrapped with a+-- Maybe, and any Nothing elements are mapped to X's unknowns.+toS' :: (Clock c, Rep a) => [Maybe a] -> Signal c a+toS' = toSX . map optX++-- | Convert a list of X values to a Signal. Pad the end with an infinite list of X unknowns.+toSX :: forall a c . (Clock c, Rep a) => [X a] -> Signal c a+toSX xs = mkShallowS (S.fromFiniteList xs unknownX)++-- | Convert a Signal of values into a list of Maybe values.+fromS :: (Rep a) => Signal c a -> [Maybe a]+fromS = fmap unX . S.toList . shallowS++-- | Convret a Signal of values into a list of representable values.+fromSX :: (Rep a) => Signal c a -> [X a]+fromSX = S.toList . shallowS++-- | take the first n elements of a 'Signal'; the rest is undefined.+takeS :: (Rep a, Clock c) => Int -> Signal c a -> Signal c a+takeS n s = mkShallowS (S.fromFiniteList (take n (S.toList (shallowS s))) unknownX)++-- | Compare the first depth elements of two Signals.+cmpSignalRep :: forall a c . (Rep a) => Int -> Signal c a -> Signal c a -> Bool+cmpSignalRep depth s1 s2 = and $ take depth $ S.toList $ S.zipWith cmpRep+ (shallowS s1)+ (shallowS s2)++-----------------------------------------------------------------------------------++instance Dual (Signal c a) where+ dual c d = Signal (shallowS c) (deepS d)++-- | Return the Lava type of a representable signal.+typeOfS :: forall w clk sig . (Rep w, sig ~ Signal clk) => sig w -> Type +typeOfS _ = repType (Witness :: Witness w)++-- | The Pack class allows us to move between signals containing compound data+-- and signals containing the elements of the compound data. This is done by+-- commuting the signal type constructor with the type constructor representing+-- the compound data. For example, if we have a value x :: Signal sig => sig+-- (a,b), then 'unpack x' converts this to a (sig a, sig b). Dually, pack takes+-- (sig a,sig b) to sig (a,b).++class Pack clk a where+ type Unpacked clk a+ -- ^ Pull the sig type *out* of the compound data type.+ pack :: Unpacked clk a -> Signal clk a+ -- ^ Push the sign type *into* the compound data type.+ unpack :: Signal clk a -> Unpacked clk a+++-- | Given a function over unpacked (composite) signals, turn it into a function+-- over packed signals.+mapPacked :: (Pack i a, Pack i b, sig ~ Signal i) => (Unpacked i a -> Unpacked i b) -> sig a -> sig b+mapPacked f = pack . f . unpack++-- | Lift a binary function operating over unpacked signals into a function over a pair of packed signals.+zipPacked :: (Pack i a, Pack i b, Pack i c, sig ~ Signal i) + => (Unpacked i a -> Unpacked i b -> Unpacked i c) + -> sig a -> sig b -> sig c+zipPacked f x y = pack $ f (unpack x) (unpack y)++instance (Rep a, Rep b) => Pack i (a,b) where+ type Unpacked i (a,b) = (Signal i a,Signal i b)+ pack (a,b) = primS2 (,) "pair" a b+ unpack ab = ( primS1 (fst) "fst" ab+ , primS1 (snd) "snd" ab+ )++instance (Rep a, Rep b, Rep c) => Pack i (a,b,c) where+ type Unpacked i (a,b,c) = (Signal i a,Signal i b, Signal i c)+ pack (a,b,c) = primS3 (,,) "triple" a b c+ unpack abc = ( primS1 (\(x,_,_) -> x) "fst3" abc+ , primS1 (\(_,x,_) -> x) "snd3" abc+ , primS1 (\(_,_,x) -> x) "thd3" abc+ )+++instance (Rep a) => Pack i (Maybe a) where+ type Unpacked i (Maybe a) = (Signal i Bool, Signal i a)++ pack (a,b) = primXS2 (\ a' b' -> case unX a' of+ Nothing -> optX Nothing+ Just False -> optX $ Just Nothing+ Just True -> optX $ case unX b' of+ Nothing -> Nothing+ Just v -> Just (Just v))+ "pair" a b+ unpack ma = ( primXS1 (\ a -> case unX a of+ Nothing -> optX Nothing+ Just Nothing -> optX (Just False)+ Just (Just _) -> optX (Just True))+ "fst" ma+ , primXS1 (\ a -> case unX a of+ Nothing -> optX Nothing+ Just Nothing -> optX Nothing+ Just (Just v) -> optX (Just v))+ "snd" ma+ )+++{-+instance (Rep a, Rep b, Rep c, Signal sig) => Pack sig (a,b,c) where+ type Unpacked sig (a,b,c) = (sig a, sig b,sig c)+ pack (a,b,c) = liftS3 (\ (Comb a' ae) (Comb b' be) (Comb c' ce) ->+ Comb (XTriple (a',b',c'))+ (entity3 (Prim "triple") ae be ce))+ a b c+ unpack abc = ( liftS1 (\ (Comb (XTriple (a,_b,_)) abce) -> Comb a (entity1 (Prim "fst3") abce)) abc+ , liftS1 (\ (Comb (XTriple (_,b,_)) abce) -> Comb b (entity1 (Prim "snd3") abce)) abc+ , liftS1 (\ (Comb (XTriple (_,_,c)) abce) -> Comb c (entity1 (Prim "thd3") abce)) abc+ )+-}++unpackMatrix :: (Rep a, Size x, sig ~ Signal clk) => sig (M.Matrix x a) -> M.Matrix x (sig a)+unpackMatrix a = unpack a++packMatrix :: (Rep a, Size x, sig ~ Signal clk) => M.Matrix x (sig a) -> sig (M.Matrix x a)+packMatrix a = pack a++instance (Rep a, Size ix) => Pack clk (Matrix ix a) where+ type Unpacked clk (Matrix ix a) = Matrix ix (Signal clk a)+ pack m = Signal shallow+ deep+ where+ shallow :: (S.Stream (X (Matrix ix a)))+ shallow = id+ $ S.fromList -- Stream (X (Matrix ix a))+ $ fmap XMatrix -- [(X (Matrix ix a))]+ $ fmap M.fromList -- [Matrix ix (X a)]+ $ List.transpose -- [[X a]]+ $ fmap S.toList -- [[X a]]+ $ fmap shallowS -- [Stream (X a)]+ $ M.toList -- [sig a]+ $ m -- Matrix ix (sig a)++ deep :: D (Matrix ix a)+ deep = D + $ Port "o0" + $ E + $ Entity (Prim "concat")+ [("o0",repType (Witness :: Witness (Matrix ix a)))]+ [ ("i" ++ show i,repType (Witness :: Witness a),unD $ deepS $ x)+ | (x,i) <- zip (M.toList m) ([0..] :: [Int])+ ]++ unpack ms = forAll $ \ i -> Signal (shallow i) (deep i)+ + where mx :: (Size ix) => Matrix ix Integer+ mx = matrix (Prelude.zipWith (\ _ b -> b) (M.indices mx) [0..])++ deep i = D + $ Port "o0" + $ E + $ Entity (Prim "index")+ [("o0",repType (Witness :: Witness a))]+ [("i0",GenericTy,Generic (mx ! i))+ ,("i1",repType (Witness :: Witness (Matrix ix a)),unD $ deepS ms)+ ]++ shallow i = fmap (liftX (M.! i)) (shallowS ms)++----------------------------------------------------------------++-- | a delay is a register with no defined default / initial value.+delay :: forall a clk . (Rep a, Clock clk) => Signal clk a -> Signal clk a+delay ~(Signal line eline) = res+ where+ def = optX $ Nothing++ -- rep = toRep def+ res = Signal sres1 (D $ Port ("o0") $ E $ entity)++ sres0 = line+ sres1 = S.Cons def (Just sres0)++ entity = Entity (Prim "delay")+ [("o0", typeOfS res)]+ [("i0", typeOfS res, unD eline),+ ("clk",ClkTy, Pad "clk"),+ ("rst",B, Pad "rst")+ ]+-- | delays generates a serial sequence of n delays.+delays :: forall a clk . (Rep a, Clock clk) => Int -> Signal clk a -> Signal clk a+delays n ss = iterate delay ss !! n+++-- | A register is a state element with a reset. The reset is supplied by the clock domain in the Signal.+register :: forall a clk . (Rep a, Clock clk) => a -> Signal clk a -> Signal clk a+register first ~(Signal line eline) = res+ where+ def = optX $ Just first++ rep = toRep def+ res = Signal sres1 (D $ Port ("o0") $ E $ entity)++ sres0 = line+ sres1 = S.Cons def (Just sres0)++ entity = Entity (Prim "register")+ [("o0", typeOfS res)]+ [("i0", typeOfS res, unD eline),+ ("def",GenericTy,Generic (fromRepToInteger rep)),+ ("clk",ClkTy, Pad "clk"),+ ("rst",B, Pad "rst")+ ]+-- | registers generates a serial sequence of n registers, all with the same initial value.+registers :: forall a clk . (Rep a, Clock clk) => Int -> a -> Signal clk a -> Signal clk a+registers n def ss = iterate (register def) ss !! n+++-----------------------------------------------------------------------------------+-- The 'deep' combinators, used to build the deep part of a signal.+++entityD :: forall a . (Rep a) => String -> D a+entityD nm = D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))] + []++entityD1 :: forall a1 a . (Rep a, Rep a1) => String -> D a1 -> D a+entityD1 nm (D a1) + = D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))] + [("i0",repType (Witness :: Witness a1),a1)]++entityD2 :: forall a1 a2 a . (Rep a, Rep a1, Rep a2) => String -> D a1 -> D a2 -> D a+entityD2 nm (D a1) (D a2) + = D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]+ [("i0",repType (Witness :: Witness a1),a1)+ ,("i1",repType (Witness :: Witness a2),a2)]+ +entityD3 :: forall a1 a2 a3 a . (Rep a, Rep a1, Rep a2, Rep a3) => String -> D a1 -> D a2 -> D a3 -> D a+entityD3 nm (D a1) (D a2) (D a3) + = D $ Port "o0" $ E $ Entity (Prim nm) [("o0",repType (Witness :: Witness a))]+ [("i0",repType (Witness :: Witness a1),a1)+ ,("i1",repType (Witness :: Witness a2),a2)+ ,("i2",repType (Witness :: Witness a3),a3)]++pureD :: (Rep a) => a -> D a+pureD a = pureXD (pureX a)++pureXD :: (Rep a) => X a -> D a+pureXD a = D $ Lit $ toRep a+
+ Language/KansasLava/Stream.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | This implementation of the Stream data type. It's defined similarly to+-- other implementation of infinite streams found on hackage, except the+-- elements of the stream are strict to prevent some space leaks.+module Language.KansasLava.Stream where++import Data.Traversable+import qualified Data.Foldable as F+import Control.Applicative+import Control.Monad+import Prelude hiding (zipWith,zipWith3, repeat)+import Data.Monoid+import qualified Data.List as List+import Data.Dynamic+import Debug.Trace++-- | Set the precedence of infix `Cons`.+infixr 5 `Cons`++-- | A stream is an infinite sequence of values.+data Stream a = Cons !a (Maybe (Stream a)) + -- ^ Cons takes a head and an optional tail.+ -- If the tail is empty, then the last value is repeated.+ deriving (Typeable)++instance Show a => Show (Stream a) where+ show (Cons a opt_as) = show a ++ " " ++ maybe "" show opt_as++instance Applicative Stream where+ pure a = a `Cons` Nothing+ (h1 `Cons` t1) <*> (h2 `Cons` t2) = h1 h2 `Cons` (t1 `opt_ap` t2)+ where+ Nothing `opt_ap` Nothing = Nothing+ Nothing `opt_ap` (Just x) = Just (pure h1 <*> x)+ (Just f) `opt_ap` Nothing = Just (f <*> pure h2)+ (Just f) `opt_ap` (Just x) = Just (f <*> x)+ +instance Functor Stream where+ fmap f (a `Cons` opt_as) = f a `Cons` maybe Nothing (Just . fmap f) opt_as++-- | Lift a value to be a constant stream.+--repeat :: a -> Stream a+--repeat a = a `Cons` repeat a++-- | Zip two streams together.+zipWith :: (a -> b -> c) -> Stream a -> Stream b -> Stream c+zipWith f xs ys = f <$> xs <*> ys++-- | Zip three streams together.+zipWith3 :: (a -> b -> c -> d) -> Stream a -> Stream b -> Stream c -> Stream d+zipWith3 f xs ys zs = f <$> xs <*> ys <*> zs++-- | Convert a list to a stream. If the list is finite, then the last element of+-- the stream will be an error.+fromFiniteList :: [a] -> a -> Stream a+fromFiniteList (x : xs) end = x `Cons` (Just (fromFiniteList xs end))+fromFiniteList [] end = end `Cons` Nothing++fromList :: [a] -> Stream a+fromList xs = fromFiniteList xs (error "found end of infinite list")+++-- | Convert a Stream to a lazy list.+toList :: Stream a -> [a]+toList (x `Cons` opt_xs) = x : maybe (List.repeat x) toList opt_xs ++instance F.Foldable Stream where+ foldMap f (a `Cons` opt_as) = f a `mappend` maybe (F.foldMap f (a `Cons` opt_as))+ (F.foldMap f)+ opt_as++instance Traversable Stream where+ traverse f (a `Cons` opt_as) = Cons <$> f a <*> maybe (pure Nothing) (\ as -> Just <$> traverse f as) opt_as++observeStream :: (Show a) => String -> Stream a -> Stream a+observeStream nm (Cons a rest) = trace (show (nm,a)) $ Cons a $+ case rest of+ Nothing -> trace (show (nm,".")) $ Nothing+ Just xs -> Just $ observeStream nm xs
+ Language/KansasLava/Test.hs view
@@ -0,0 +1,836 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables, FlexibleContexts, DeriveDataTypeable #-}+module Language.KansasLava.Test+ ( testMe+ , neverTestMe+ , verbose+ , fileReporter+ , TestSeq(..)+ , testFabrics+ , Gen(..)+ , arbitrary+ , allCases+ , finiteCases+ , testDriver+ , generateReport+ , Options(..)+ , matchExpected+ , StreamTest(..)+ , testStream+ ) where++import Language.KansasLava.Fabric+import Language.KansasLava.Protocols+import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Utils+import Language.KansasLava.VCD+import Language.KansasLava.VHDL+import Control.Concurrent.MVar+import Control.Concurrent (forkIO)+import Control.Exception++-- found in dist/build/autogen+import Paths_kansas_lava++import Control.Applicative+import qualified Control.Exception as E+import Control.Monad+import Data.List as List+import Data.Maybe as Maybe+import Data.Default+--import Data.Sized.Unsigned++import System.Cmd+import System.Console.CmdArgs hiding (Default,def,name,summary,opt)+import System.Directory+import System.Environment+import System.Exit+import System.FilePath as FP+import qualified System.IO.Strict as Strict+import qualified System.Random as R+import Data.Sized.Ix+--import System.Random++import qualified Language.KansasLava.Stream as S+++-------------------------------------------------------------------------------------++-- data TestData = Rand Int | Complete++testMe :: String -> Maybe [String] -> Bool+testMe _ Nothing = True+testMe nm (Just nms) = or [ (n `isInfixOf` nm) | n <- nms ]++neverTestMe :: String -> [String] -> Bool+neverTestMe nm nms = or [ (n `isInfixOf` nm) | n <- nms ]++verbose :: Int -> String -> Int -> String -> IO ()+verbose vlvl name n m | vlvl >= n = putStrLn (name ++ " :" ++ take n (repeat ' ') ++ m)+ | otherwise = return ()++fileReporter :: FilePath -> FilePath -> Result -> IO ()+fileReporter path nm res = do+ createDirectoryIfMissing True (path </> nm)+ writeFile (path </> nm </> "result") $ show res++-------------------------------------------------------------------------------------++-- Given a circuit that returns an a, and the expected results,+-- do some tests for sanity.++data TestSeq = TestSeq+ (String -> Int -> Fabric () -> (Fabric (Int -> Maybe String)) -> IO ())+ () -- remove the unit++{-+-- | Fabric outputs are equal if for each output from the left fabric,+-- there exists an output in the right fabric with the same name, type,+-- and sequence of values. Sequences are compared with cmpRepValue,+-- so the left fabric is the 'golden' fabric, and may be more general+-- in respect to unknowns than the right fabric.+cmpFabricOutputs :: Int -> [(String,Pad)] -> [(String,Pad)] -> Bool+cmpFabricOutputs count expected shallow =+ and [ n1 == n2+ && ty1 == ty2+ && (and $ List.zipWith cmpRepValue (take count ereps) sreps)+ | ((n1,pad1),(n2,pad2)) <- zip expected shallow+ , let (ty1,ereps) = getTyRep pad1+ , let (ty2,sreps) = getTyRep pad2+ ]+ where getTyRep :: Pad -> (StdLogicType, [RepValue])+ getTyRep pad = case pad of+ StdLogic s -> (padStdLogicType pad,map toRep $ toList $ shallowS s)+ StdLogicVector s -> (padStdLogicType pad,map toRep $ toList $ shallowS s)+ GenericPad _ -> error "testFabrics: Generic output pad?"+-}++type SimMods = [(String,KLEG -> IO KLEG)]++testFabrics+ :: Options -- Options+ -> SimMods -- ^ [(String,KLEG -> IO KLEG)]+ -> String -- Test Name+ -> Int -- Number of Cycles+ -> Fabric () -- DUT+ -> (Fabric (Int -> Maybe String)) -- Driver+ -> IO ()+testFabrics opts simMods name count f_dut f_expected+ | testMe name (testOnly opts) && not (neverTestMe name (testNever opts)) = (do+++ verb 2 $ "testing(" ++ show count ++ ")"++ let inp :: [(String,Pad)]+ (expected_fn,inp) = runFabric f_expected shallow++ shallow :: [(String,Pad)]+ (_,shallow) = runFabric f_dut inp++ expected = expected_fn count++ verb 9 $ show ("shallow",shallow)+ verb 9 $ show ("expected",expected)++ case expected of+ Nothing -> do+ verb 3 $ "shallow passed"+ if genSim opts+ then do createDirectoryIfMissing True path++ -- get permuted/unpermuted list of sims for which we generate testbenches+ let sims = [ (modname, (mkTestbench' (path </> modname) count (snd cmod) f_dut inp))+ | cmod <- if permuteMods opts+ then map (foldr (\(nm,m) (nms,ms) -> (nm </> nms, m >=> ms)) ("unmodified", (return)))+ $ concatMap permutations+ $ subsequences+ $ simMods+ else simMods+ , let modname = fst cmod+ ]++ -- generate each testbench, report any failures+ ts <- sequence [ do vrb 2 $ "generating simulation"+ E.catch (Just <$> action)+ (\e -> do vrb 3 "vhdl generation failed"+ vrb 4 $ show (e :: E.SomeException)+ rep $ CodeGenFail -- (show (e :: E.SomeException))+ return Nothing)+ | (modname, action) <- sims+ , let rep = report (name </> modname)+ , let vrb = verbose (verboseOpt opts) (name </> modname)+ ]++ -- for successfully generated testbenches, add some files+ sequence_ [ do writeFile (path </> modname </> "Makefile") $ localMake (name </> modname)+ copyLavaPrelude (path </> modname)+ writeFile (path </> modname </> "options") $ show opts+ rep $ SimGenerated+ vrb 9 $ show ("trace",fromJust t)+ | (modname, t) <- zip (map fst sims) ts+ , isJust t+ , let vrb = verbose (verboseOpt opts) (name </> modname)+ , let rep = report (name </> modname)+ ]++ return ()+ else report name ShallowPass+ Just msg -> do+ verb 1 $ "shallow FAILED"+-- t_dut <- mkTrace (return count) f_dut inp+-- verb 4 "DUT:"+-- verb 4 $ show t_dut+-- verb 4 "EXPECT IN:"+-- verb 4 $ show $ take count shallow+-- verb 4 "EXPECT OUT MESSAGE:"+ verb 4 $ msg+ report name $ ShallowFail) `E.catch`+ (\ (e :: E.SomeException) -> do verb 2 $ ("SomeException: " ++ show e)+ report name TestAborted)+ | otherwise = return ()+ where+ verb = verbose (verboseOpt opts) name+ path = (simPath opts) </> name+ report = fileReporter $ simPath opts++simCompare :: FilePath -> (Result -> IO ()) -> (Int -> String -> IO ()) -> IO ()+simCompare path report verb = do+ let localname = last $ splitPath path++ ran <- doesFileExist $ path </> "transcript"+ if ran+ then do -- transcript <- Strict.readFile (path </> "transcript")+ success <- doesFileExist $ path </> localname <.> "out.tbf"+ if success+ then do shallow <- lines <$> Strict.readFile (path </> localname <.> "in.tbf")+ deep <- lines <$> Strict.readFile (path </> localname <.> "out.tbf")+ sig <- read <$> Strict.readFile (path </> localname <.> "sig")++ let t1 = readTBF shallow sig+ t2 = readTBF deep sig+ if cmpVCD (ioOnly t1) (ioOnly t2)+ then do verb 3 "simulation passed"+ report $ Pass -- t1 t2 transcript+ else do verb 3 "simulation failed"+-- verb 4 $ show ("shallow",t1)+-- verb 4 $ show ("deep",t2)+ report $ CompareFail++ else do verb 3 "VHDL compilation failed"+-- verb 4 transcript+ report $ CompileFail -- transcript+ else verb 1 "Simulation hasn't been run, transcript file missing."++postSimulation :: FilePath -> IO ()+postSimulation spath = go "" spath+ where go :: String -> FilePath -> IO ()+ go name path = do+ isSimDir <- doesFileExist $ path </> "transcript"+ if isSimDir+ then simCompare path (fileReporter spath name) (verbose 9 name)+ else return ()++ contents <- getDirectoryContents path+ subdirs <- filterM (\(_,f) -> doesDirectoryExist f)+ [ (name </> f, path </> f)+ | f <- contents+ , f /= "."+ , f /= ".." ]++ mapM_ (uncurry go) subdirs++prepareSimDirectory :: Options -> IO ()+prepareSimDirectory opts = do+ let path = simPath opts+ putStrLn $ "preparing simulation directory: ./" ++ path+ pwd <- getCurrentDirectory++ -- Calling out to rm -rf is safer than Haskell's removeDirectoryRecursive, which+ -- follows symlinks. However, this still seems dangerous to put here,+ -- so we do a bit of checking to make sure we can't delete anything+ -- outside the present working directory.+ ok <- doesDirectoryExist $ pwd </> path+ if ok && not (isInfixOf ".." path)+ then do _ <- system $ "rm -rf " ++ path+ return ()+ else return ()++ createDirectoryIfMissing True path++ writeFile (path </> "runsims") $ unlines testRunner+ _ <- system $ "chmod +x " ++ path </> "runsims"++ return ()++testRunner :: [String]+testRunner = [+ "#!/bin/bash",+ "",+ "if [ \"$1\" == \"isim\" ] ; then",+ "\tCMD=\"make isim\"",+ "else",+ "\tCMD=\"vsim -c -do unmodified.do\"",+ "fi",+ "if type -P parallel; then",+ "echo \"Using parallel simulation\"",+ "",+ "[ -n \"$LAVA_MODELSIM_HOSTS\" ] || export LAVA_MODELSIM_HOSTS=\":\"",+ "echo \"Using $LAVA_MODELSIM_HOSTS for simulation\"",+ "",+ "find . -iname \"*.do\" | parallel dirname | \\",+ "\tparallel -j 300% --eta -W /tmp --sshlogin $LAVA_MODELSIM_HOSTS \\",+ "\t--transfer --return {} \"cd {} && $CMD > /dev/null\"",+ "else",+ "\t\tcurdir=`pwd`",+ "\t\techo \"Using sequential simulation\"",+ "\t\tfind . -iname \"*.do\" | while read f",+ "\t\tdo",+ "\t\t\t\techo \"Simulating: $f\"",+ "\t\t\t\tp=`dirname \"$f\"`",+ "\t\t\t\tb=`basename \"$f\"`",+ "\t\t\t\tcd $p",+ "\t\t\t\tres=`vsim -c -do $b`",+ "\t\t\t\techo $res >> sim.log",+ "\t\t\t\tcd $curdir",+ "\t\tdone;",+ "fi"+ ]+++localMake :: String -> String+localMake relativePath = unlines+ ["vsim:"+ ,"\tvsim -c -do " ++ name ++ ".do"+ ,""+ ,"diff:"+ ,"\t" ++ dots </> "dist/build/kansas-lava-tbf2vcd/kansas-lava-tbf2vcd --diff " ++ name ++ ".sig " ++ name ++ ".in.tbf " ++ name ++ ".out.tbf diff.vcd"+ ,"\tgtkwave diff.vcd"+ ,""+ ,"vcd:"+ ,"\twlf2vcd vsim.wlf > " ++ name ++ ".vcd"+ ,""+ ,"view: vcd"+ ,"\tgtkwave " ++ name ++ ".vcd"+ ,""+ ,"isim: unmodified_sim " ++ name ++ ".tcl"+ ,"\t./" ++ name ++ "_sim -tclbatch " ++ name ++ ".tcl"+ ,""+ ,name ++ "_sim: " ++ name ++ ".vhd Lava.vhd " ++ name ++ ".prj"+ ,"\tfuse -prj " ++ name ++ ".prj work." ++ name ++ "_tb -o " ++ name ++ "_sim"+ ,""+ ,name ++ ".prj:"+ ,"\techo \"vhdl work Lava.vhd\" > " ++ name ++ ".prj"+ ,"\techo \"vhdl work " ++ name ++ ".vhd\" >> " ++ name ++ ".prj"+ ,"\techo \"vhdl work " ++ name ++ "_tb.vhd\" >> " ++ name ++ ".prj"+ ,""+ ,name ++ ".tcl:"+ ,"\techo \"vcd dumpfile " ++ name ++ ".vcd\" > " ++ name ++ ".tcl"+ ,"\techo \"vcd dumpvars -m / \" >> " ++ name ++ ".tcl"+ ,"\techo \"vcd dumpon\" >> " ++ name ++ ".tcl"+ ,"\techo \"run all\" >> " ++ name ++ ".tcl"+ ,"\techo \"vcd dumpoff\" >> " ++ name ++ ".tcl"+ ,"\techo \"quit\" >> " ++ name ++ ".tcl"+ ]+ where dots = joinPath $ replicate l ".."+ l = 2 + (length $ splitPath relativePath)+ name = last $ splitPath relativePath++preludeFile :: String+preludeFile = "Lava.vhd"++copyLavaPrelude :: FilePath -> IO ()+copyLavaPrelude dest = do+ file <- readPreludeFile ("Prelude/VHDL/" </> preludeFile)+ writeFile (dest </> preludeFile) file++-------------------------------------------------------------------------------------++data Gen a = Gen Integer (Integer -> Maybe a)++arbitrary :: forall w . (Rep w) => Gen w+arbitrary = Gen sz integer2rep+ where+ sz = 2 ^ (fromIntegral (repWidth (Witness :: Witness w)) :: Int)+ integer2rep :: Integer -> Maybe w+ integer2rep v = unX+ $ fromRep+ $ RepValue+ $ take (repWidth (Witness :: Witness w))+ $ map Just+ $ map odd+ $ iterate (`div` 2)+ $ (fromIntegral v :: Int)++------------------------------------------------------------------------------------+-- The new testing system.++-- | 'allCases' returns all values of type w, in a non-random order.+allCases :: (Rep w) => [w]+allCases = Maybe.catMaybes $ fmap f [0..(n-1)]+ where (Gen n f) = arbitrary++-- | 'finiteCases' returns finite values, perhaps many times, in a random order.+finiteCases :: (Rep w) => Int ->[w]+finiteCases i = take i $ Maybe.catMaybes $ fmap f $ R.randomRs (0,n-1) (R.mkStdGen 0)+ where (Gen n f) = arbitrary++-------------------------------------------------------------------++data Report = Report Summary [TestCase]++instance Show Report where+ show (Report s _) = show s++data Summary = Summary { sfail :: Int+ , spass :: Int+ , generated :: Int+ , codegenfail :: Int+ , vhdlfail :: Int+ , simfail :: Int+ , compfail :: Int+ , testaborted :: Int+ , passed :: Int+ , total :: Int+ }+++instance Show Summary where+ show summary = unlines [tt,sf,sp,rf,gn,vf,cp,si,ja,ps]+ where tt = "Total tests: " ++ show (total summary)+ sf = "Shallow test failures: " ++ show (sfail summary)+ sp = "Shallow tests passed: "+ ++ case spass summary of+ 0 -> show $ sum [ fn summary+ | fn <- [generated, codegenfail, vhdlfail, simfail, compfail, passed]+ ]+ x -> show x+ rf = "VHDL generation failures: " ++ show (codegenfail summary)+ gn = "Simulations generated: "+ ++ case generated summary of+ 0 -> show $ sum [ fn summary+ | fn <- [vhdlfail, simfail, compfail, passed]+ ]+ x -> show x+ vf = "VHDL compilation failures: " ++ show (vhdlfail summary)+ cp = "Simulation failures (non-matching traces): " ++ show (compfail summary)+ si = "Simulation failures (other): " ++ show (simfail summary)+ ja = "Tests that just aborted: " ++ show (testaborted summary)+ ps = "Simulation tests passed: " ++ show (passed summary)++generateReport :: FilePath -> IO ()+generateReport path = do+ postSimulation path+ r <- buildReport <$> buildResults path++ putStrLn $ show r++ html <- reportToHtml r+ writeFile "report.html" html+ shtml <- reportToSummaryHtml r+ writeFile "summary.html" shtml++-- Traverses all the generated simulation directories and reads the result files.+buildResults :: FilePath -> IO [TestCase]+buildResults spath = go "" spath+ where go :: String -> FilePath -> IO [TestCase]+ go name path = do+ resE <- doesFileExist $ path </> "result"+ res <- if resE+ then liftM (\r -> [(name,r)]) (read <$> (Strict.readFile $ path </> "result"))+ else return []++ contents <- getDirectoryContents path+ subdirs <- filterM (\(_,f) -> doesDirectoryExist f)+ [ (name </> f, path </> f)+ | f <- contents+ , f /= "."+ , f /= ".." ]++ subresults <- concat <$> (mapM (uncurry go) subdirs)++ return $ res ++ subresults++addtoSummary :: Result -> Summary -> Summary+addtoSummary (ShallowFail {}) s = s { sfail = 1 + (sfail s) }+addtoSummary ShallowPass s = s { spass = 1 + (spass s) }+addtoSummary SimGenerated s = s { generated = 1 + (generated s) }+addtoSummary (CodeGenFail {}) s = s { codegenfail = 1 + (codegenfail s) }+addtoSummary (CompileFail {}) s = s { vhdlfail = 1 + (vhdlfail s) }+addtoSummary (SimFail {}) s = s { simfail = 1 + (simfail s) }+addtoSummary (CompareFail {}) s = s { compfail = 1 + (compfail s) }+addtoSummary (TestAborted) s = s { testaborted = 1 + (testaborted s) }+addtoSummary (Pass {}) s = s { passed = 1 + (passed s) }++buildReport :: [TestCase] -> Report+buildReport rs = Report summary rs+ where rs' = map snd rs+ summary = foldr addtoSummary (Summary 0 0 0 0 0 0 0 0 0 (length rs')) rs'++reportToSummaryHtml :: Report -> IO String+reportToSummaryHtml (Report summary _) = do+ header <- readPreludeFile "Prelude/HTML/header.inc"+ mid <- readPreludeFile "Prelude/HTML/mid.inc"+ footer <- readPreludeFile "Prelude/HTML/footer.inc"++ return $ header ++ (summaryToHtml summary) ++ mid ++ footer++summaryToHtml :: Summary -> String+summaryToHtml s = unlines [ "<table>"+ , "<tr class=\"huge " ++ sclass ++ "\"><td>Shallow Failures:</td><td>" ++ show (sfail s) ++ "</td><td>(" ++ show (total s - sfail s) ++ "/" ++ show (total s) ++ " passed)</td></tr>"+ , "<tr class=\"huge " ++ dclass ++ "\"><td>Simulation Failures:</td><td>" ++ show (sum [codegenfail s, vhdlfail s, compfail s, simfail s]) +++ "</td><td>(" ++ show (passed s) ++ "/" ++ show (total s - sfail s) ++ " passed)</td></tr>"+ , "</table>"+ , "<hr width=\"90%\">"+ , "<table>"+ , "<tr id=\"cgf\" class=\"kindahuge\"><td>VHDL Generation Failures:</td><td>" ++ show (codegenfail s) ++ "</td></tr>"+ , "<tr id=\"vcf\" class=\"kindahuge\"><td>VHDL Compilation Failures:</td><td>" ++ show (vhdlfail s) ++ "</td></tr>"+ , "<tr id=\"cpf\" class=\"kindahuge\"><td>Comparison Failures:</td><td>" ++ show (compfail s) ++ "</td></tr>"+ , "<tr id=\"osf\" class=\"kindahuge\"><td>Other Simulation Failures:</td><td>" ++ show (simfail s) ++ "</td></tr>"+ , "</table>"+ ]+ where chooser x = case x of+ 0 -> "allpass"+ i | i == total s -> "allfail"+ _ -> "somepass"+ sclass = chooser $ sfail s+ dclass = chooser $ total s - sfail s - passed s+++reportToHtml :: Report -> IO String+reportToHtml (Report summary results) = do+ header <- readPreludeFile "Prelude/HTML/header.inc"+ mid <- readPreludeFile "Prelude/HTML/mid.inc"+ footer <- readPreludeFile "Prelude/HTML/footer.inc"++ let showall = "<a href=\"#\" id=\"showall\">Show All</a>"+ res = unlines [ concat ["<div id=\"", name, "\" class=\"header ", sc, "\">", name+ ,"<span class=\"status\">", s, "</span></div>\n<div class=\"additional\">"+ , "</div>"]+ | (name, r) <- results+ , let (sc, s) = case r of+ ShallowFail {}-> ("shallowfail", "Shallow Failed")+ ShallowPass -> ("shallowpass", "Shallow Passed")+ SimGenerated -> ("simgenerated", "Simulation Generated")+ CodeGenFail {} -> ("codegenfail", "VHDL Generation Failed")+ CompileFail {} -> ("compilefail", "VHDL Compilation Failed")+ SimFail {} -> ("simfail", "Simulation Failed (other)")+ CompareFail {} -> ("comparefail", "Failed")+ TestAborted {} -> ("testabort", "Test Aborted")+ Pass {} -> ("pass", "Passed")+ ]+ return $ header ++ (summaryToHtml summary) ++ mid ++ showall ++ res ++ footer++--unDiv :: [String] -> String+--unDiv = foldr (\s t -> "<div>" ++ sliceString 200 80 s ++ "</div>" ++ t) ""++--sliceString :: Int -> Int -> String -> String+--sliceString r c str = unlines $ take r $ chunk str+-- where chunk [] = []+-- chunk s = let (c1,r') = splitAt c s in c1 : chunk r'++testDriver :: Options -> [TestSeq -> IO ()] -> IO ()+testDriver dopt tests = do+ opt <- cmdArgs dopt++ putStrLn "Running with the following options:"+ putStrLn $ show opt++ prepareSimDirectory opt++ work <- newEmptyMVar :: IO (MVar (Either (MVar ()) (IO ())))++ let thread_count :: Int+ thread_count = parTest opt++ sequence_ [+ forkIO $+ let loop = do+ act <- takeMVar work+ case act of+ Left end -> do+ putMVar end ()+ return () -- stop command+ Right io ->+ do io `catches`+ [ Handler $ \ (ex :: AsyncException) -> do+ putStrLn ("AsyncException: " ++ show ex)+ throw ex+ , Handler $ \ (ex :: SomeException) -> do+ putStrLn ("SomeException: " ++ show ex)+ throw ex+ ]+ loop+ in loop+ | _ <- [1..thread_count]]+++ let test :: TestSeq+ test = TestSeq (\ nm sz fab fn ->+ let work_to_do = testFabrics opt [] nm sz fab fn+ in+ putMVar work (Right $ work_to_do)+-- work_to_do+ )+ ()++ -- The different tests to run (from different modules)+ sequence_ [ t test+ | t <- tests+ ]++ -- wait for then kill all the worker threads+ sequence_ [ do stop <- newEmptyMVar+ putMVar work (Left stop)+ takeMVar stop+ | _ <- [1..thread_count]+ ]+++ -- If we didn't generate simulations, make a report for the shallow results.+ if genSim opt+ then if runSim opt+ then do _ <- system $ simCmd opt+ generateReport $ simPath opt+ else do putStrLn $ unlines [""+ ,"Run simulations and generate reports using the Makefile commands"+ ,"or the individual Makefiles in each simulation subdirectory."+ ,""]+ else generateReport $ simPath opt++--------------------------------------------------------------------+++data Options = Options+ { genSim :: Bool -- ^ Generate modelsim testbenches for each test?+ , runSim :: Bool -- ^ Run the tests after generation?+ , simCmd :: String -- ^ Command to call with runSim is True+ , simPath :: FilePath -- ^ Path into which we place all our simulation directories.+ , permuteMods :: Bool -- ^ False: Run each mod separately. True: Run all possible+ -- permutations of the mods to see if they affect each other.+ , verboseOpt :: Int -- ^ See verbose table below.+ , testOnly :: Maybe [String] -- ^ Lists of tests to execute. Can match either end. Nothing means all tests.+ , testNever :: [String] -- ^ List of tests to never execute. Can match either end.+ , testData :: Int -- ^ cut off for random testing+ , parTest :: Int -- ^ how may tests to run in parallel+ } deriving (Data, Typeable)++instance Show Options where+ show (Options gs rs sc sp pm vo to tn td pt) =+ unlines [ "genSim: " ++ show gs+ , "runSim: " ++ show rs+ , "simCmd: " ++ show sc+ , "simPath: " ++ show sp+ , "permuteMods: " ++ show pm+ , "verboseOpt: " ++ show vo+ , "testOnly: " ++ show to+ , "testNever: " ++ show tn+ , "testData: " ++ show td+ , "parTest: " ++ show pt ]++++-------------------------------------------------------------------------------------+-- Verbose table+-- 1: Failures+-- 2: what was run+-- 3: what worked+-- 4: debugging from failures+-- 9: debugging from everything that happened+-------------------------------------------------------------------------------------++instance Default Options where+ def = Options+ { genSim = False &= help "Generate modelsim testbenches for each test?"+ , runSim = False &= help "Run the tests after generation?"+ , simCmd = "sims/runsims" &= help "Command to call when runSim is True"+ , simPath = "sims" &= typDir &= help "Path into which we place all our simulation directories."+ , permuteMods = True &= help "Run all possible permutations of circuit mods."+ , verboseOpt = 4 &= help "Verbosity level. 1: Failures 2: What runs 3: What succeeds 4: Failures 9: Everything"+ , testOnly = Nothing &= help "List of tests to execute. Can match either end. Default is all tests."+ , testNever = [] &= help "List of tests to never execute. Can match either end."+ , testData = 1000 &= help "Cutoff for random testing."+ , parTest = 4 &= help "Number of tests to run in parallel."+ -- everyone has multicore now.+ -- This is the number of *threads*,+ -- so we cope with upto 4 cores.+ }++type TestCase = (String, Result)++data Result = ShallowFail {- Trace String -} -- Shallow result doesn't match expected+ | ShallowPass -- Shallow result matches, we aren't simulating+ | SimGenerated -- Shallow passed, testbench generated, not running sim+ | CodeGenFail {- String -} -- Shallow passed, testbench generation failed+ | CompileFail {- String -} -- VHDL compilation failed during simulation+ | SimFail {- String -} -- Modelsim failed for some other reason+ | CompareFail {- Trace Trace String -} -- Deep result didn't match the shallow result+ | TestAborted -- Something went badly wrong a some stage+ | Pass {- Trace Trace String -}-- Deep matches shallow which matches expected+ deriving (Show, Read)++---------------------------------------------------------------------------------------++-- | matchExpected reads a named input port from+-- a Fabric, and checks to see that it is a refinement+-- of a given "specification" of the output.+-- If there is a problem, issue an error message.++matchExpected :: (Rep a, Size (W a), Show a) => String -> Seq a -> Fabric (Int -> Maybe String)+matchExpected out_name ref = do+ o0 <- inStdLogicVector out_name+ let sq = o0 `refinesFrom` ref+ return $ \ count ->+ case [ (i::Int,o,r)+ | (i,v,o,r) <- take (fromIntegral count)+ $ zip4 [0..]+ (fromS sq)+ (S.toList (fmap (show . unRepValue . toRep) (shallowS o0)))+ (S.toList (fmap (show . unRepValue . toRep) (shallowS ref)))++ , v /= Just True+ ] of+ [] -> Nothing+ ns -> Just $ "failed on cycles " ++ show (take 20 $ ns)+++----------------------------------------------------------------------------++data StreamTest w1 w2 = StreamTest+ { theStream :: Patch (Seq (Enabled w1)) (Seq (Enabled w2))+ (Seq Ack) (Seq Ack)+ , correctnessCondition :: [w1] -> [w2] -> Maybe String+ , theStreamTestCount :: Int+ , theStreamTestCycles :: Int+ , theStreamName :: String+ }++testStream :: forall w1 w2 . ( Eq w1, Rep w1, Show w1, Size (W w1)+ , Eq w2, Rep w2, Show w2, Size (W w2)+ )+ => TestSeq -> String -> StreamTest w1 w2 -> IO ()+testStream (TestSeq test _) tyName streamTest = do++ let vals0 :: [Maybe w1]+ vals0 = finiteCases (fromIntegral (theStreamTestCycles streamTest))++ vals1 :: [Int]+ vals1 = drop (fromIntegral (theStreamTestCount streamTest))+ [ n+ | (Just _,n) <- zip vals0 [0..]+ ]++ vals :: [Maybe w1]+ vals = case vals1 of+ [] -> vals0+ (n:_) -> [ if i < n then v else Nothing+ | (v,i) <- zip vals0 [0..]+ ]++{-+ print (theStreamTestCount StreamTest,theStreamTestCycles StreamTest)+ print vals0+ print vals1+ print vals+-}+ -- good enough for this sort of testing+-- let stdGen = mkStdGen 0++ let -- (lhs_r,rhs_r) = split stdGen++ cir = theStream streamTest++ driver :: Fabric (Int -> Maybe String)+ driver = do+ -- backedge output from DUT+ ack <- inStdLogic "ack" :: Fabric (Seq Ack)++ let vals2 :: Seq (Enabled w1)+ (_,vals2) = toAckBox' a (vals ++ Prelude.repeat Nothing,ack)++ -- sent to DUT+ outStdLogicVector "vals" (enabledVal vals2)+ outStdLogic "vals_en" (isEnabled vals2)++ -- DUT does stuff++ -- reading from DUT+ res <- inStdLogicVector "res"+ res_en <- inStdLogic "res_en"++ let flag :: Seq Ack+ opt_as :: [Maybe w2]++ (flag, opt_as) = fromAckBox' d (packEnabled res_en res,())++ outStdLogic "flag" flag++ return $ \ n -> correctnessCondition streamTest+ [ x | (Just x) <- take n $ vals ]+ [ x | (Just x) <- take n $ opt_as ]++{-+let ans = [ a | Just a <- take n opt_as ]+ inp = [ a | Just a <- take n vals ]+ in if ans == take (length ans) inp+ && length inp > 1000+ then Nothing -- ("matched" ++ show (length ans))+ else Just (show (ans,inp))+-}++ dut :: Fabric ()+ dut = do+ flag <- inStdLogic "flag"+ vls <- inStdLogicVector "vals"+ vals_en <- inStdLogic "vals_en"+ let (ack,res') = cir (packEnabled vals_en vls, flag)+ outStdLogicVector "res" (enabledVal res')+ outStdLogic "res_en" (isEnabled res')+ outStdLogic "ack" ack+++ a = cycle [0..2] -- \ n -> [0.1,0.2 ..] !! fromIntegral (n `div` 10000)+ d = cycle [0..4] -- \ n -> [0.1,0.2 ..] !! fromIntegral (n `div` 10000)++ test ("stream/" ++ theStreamName streamTest ++ "/" ++ tyName) (length vals) dut driver+++-- | Get a file from the prelude. First, check the KANSAS_LAVA_ROOT system+-- environment variable. If it exists, use that. If not, try to get it from the+-- installed cabal package.+readPreludeFile :: String -> IO String+readPreludeFile fname = do+ ks <- getEnv "KANSAS_LAVA_ROOT"+ Strict.readFile (ks </> fname)+ `Prelude.catch` \_ -> do+ path <- getDataFileName fname+ Strict.readFile path+ `Prelude.catch` \_ -> do+ putStrLn "Set the KANSAS_LAVA_ROOT environment variable"+ putStrLn "to point to the root of the KsLava source directory."+ exitFailure++-----------------------------------++-- | Make a VHDL testbench from a 'Fabric' and its inputs.+mkTestbench' :: FilePath -- ^ Directory where we should place testbench files. Will be created if it doesn't exist.+ -> Int -- ^ Generate inputs for this many cycles.+ -> (KLEG -> IO KLEG) -- ^ any operations on the circuit before VHDL generation+ -> Fabric () -- ^ The Fabric for which we are building a testbench.+ -> [(String,Pad)] -- ^ Inputs to the Fabric+ -> IO VCD+mkTestbench' path cycles circuitMod fabric input = do+ let name = last $ splitPath path++ createDirectoryIfMissing True path++ (vcd, rc) <- mkVCDCM cycles fabric input circuitMod++ writeTBF (path </> name <.> "in.tbf") vcd+ writeFile (path </> name <.> "sig") $ show $ toSignature vcd+ writeFile (path </> name <.> "kleg") $ show rc++ writeVhdlCircuit name (path </> name <.> "vhd") rc+ mkTestbench name path rc++ return vcd
+ Language/KansasLava/Types.hs view
@@ -0,0 +1,694 @@+{-# LANGUAGE TypeFamilies, Rank2Types, ScopedTypeVariables, GADTs, TypeOperators, EmptyDataDecls #-}++-- | This module contains the key internal types for Kansas Lava,+-- and some basic utilities (like Show instances) for these types.+module Language.KansasLava.Types (+ -- * Types+ Type(..)+ , typeWidth+ , isTypeSigned+ , StdLogicType(..)+ , toStdLogicType+ , fromStdLogicType+ -- * Id+ , Id(..)+ , Box(..)+ -- * Entity+ , Entity(..)+ , E(..)+ , entityFind+ -- * Driver+ , Driver(..)+ , D(..)+ -- * Ways of intepreting 'Signal'+ , Clock -- type class+ , CLK+ -- * RepValue+ , RepValue(..)+ , showRepValue+ , appendRepValue+ , isValidRepValue+ , getValidRepValue+ , chooseRepValue+ , cmpRepValue+ -- * BitPat+ , BitPat(..)+ , (&)+ , bits+ , bool+ , every+ , bitPatToInteger+ -- * KLEG+ , KLEG(..)+ , visitEntities+ , mapEntities+ , allocEntities+ , Signature(..)+ , circuitSignature+ -- *Witness+ , Witness(..)+ -- * Dual shallow/deep+ , Dual(..)+ -- * Our version of tuples+ , (:>)(..)+ -- * Synthesis control+ , Synthesis(..)+ ) where++import Control.Applicative++import Data.Char+import Data.Dynamic+import qualified Data.Foldable as F+import Data.List as L+import Data.Maybe+import Data.Monoid hiding (Dual)+import Data.Reify+import Data.Ratio+import qualified Data.Traversable as T+import Data.Sized.Ix+import GHC.Exts( IsString(..) )++-------------------------------------------------------------------------+-- | Type captures HDL-representable types.+data Type+ -- basic representations+ = B -- ^ Bit+ | S Int -- ^ Signed vector, with a width.+ | U Int -- ^ Unsigned vector, with a width.+ | V Int -- ^ std_logic_vector, with a width.++ -- TODO: change to StdLogicTy, because it is clock independent+ | ClkTy -- ^ Clock Signal++ | GenericTy -- ^ generics in VHDL, argument must be integer++ | RomTy Int -- ^ a constant array of values.++ | TupleTy [Type]+ -- ^ Tuple, represented as a larger std_logic_vector+ | MatrixTy Int Type+ -- ^ Matrix, for example a vhdl array.++ -- TODO: Call this FixedPointTy+ | SampledTy Int Int+ -- ^ Our "floating" values.+ -- The first number is the precision/scale (+/- N)+ -- The second number is the bits used to represent this number+ deriving (Eq, Ord)++-- | 'typeWidth' returns the width of a type when represented in VHDL.+typeWidth :: Type -> Int+typeWidth B = 1+typeWidth ClkTy = 1+typeWidth (S x) = x+typeWidth (U x) = x+typeWidth (V x) = x+typeWidth (TupleTy tys) = sum (map typeWidth tys)+typeWidth (MatrixTy i ty) = i * typeWidth ty+typeWidth (SampledTy _ i) = i+typeWidth other = error $ show ("typeWidth",other)++-- | 'isTypeSigned' determines if a type has a signed representation. This is+-- necessary for the implementation of 'isSigned' in the 'Bits' type class.+isTypeSigned :: Type -> Bool+isTypeSigned B = False+isTypeSigned ClkTy = False+isTypeSigned (S _) = True+isTypeSigned (U _) = False+isTypeSigned (V _) = False+isTypeSigned (SampledTy {}) = True+isTypeSigned GenericTy = False+isTypeSigned (RomTy _) = False+isTypeSigned (TupleTy _) = False+isTypeSigned (MatrixTy _ _) = False++instance Show Type where+ show B = "B"+ show ClkTy = "Clk"+ show GenericTy = "G"+ show (RomTy i) = show i ++ "R"+ show (S i) = show i ++ "S"+ show (U i) = show i ++ "U"+ show (V i) = show i ++ "V"+ show (TupleTy tys) = show tys+ show (MatrixTy i ty) = show i ++ "[" ++ show ty ++ "]"+ show (SampledTy m n) = "Sampled " ++ show m ++ " " ++ show n++-- This is required for the deserialization of Trace objects.+instance Read Type where+ readsPrec p (x:xs) | isSpace x = readsPrec p xs -- chew up whitespace?+ readsPrec _ xs | hasSizePrefix xs = [fromJust $ parseSize xs]+ where hasSizePrefix = isJust . parseSize+ parseSize str = let (ds,cs) = span isDigit str+ in case cs of+ (c:rest) | not (null ds) && c `elem` ['U', 'S', 'V','R']+ -> Just (con c (read ds :: Int), rest)+ ('[':rest) | (not $ null ds) ->+ case [ (MatrixTy (read ds :: Int) ty,rest')+ | (ty,']':rest') <- reads rest+ ] of+ [] -> Nothing+ (x:_) -> Just x+ _ -> Nothing+ con ch = case ch of+ 'U' -> U+ 'S' -> S+ 'V' -> V+ 'R' -> RomTy+ ty -> error $ "Can't read type" ++ show ty+ readsPrec _ xs | "Sampled" `isPrefixOf` xs = [(SampledTy (read m :: Int) (read n :: Int),rest)]+ where ("Sampled ",r1) = break isDigit xs+ (m,' ':r2) = span isDigit r1+ (n,rest) = span isDigit r2+ readsPrec _ xs | foldr (\s b -> b || s `isPrefixOf` xs) False strs =+ concat [ maybe [] (\rest -> [(con,rest)]) (stripPrefix str xs)+ | (con,str) <- zip [B , ClkTy, GenericTy] strs+ ]+ where strs = ["B", "Clk", "G"]+ readsPrec _ xs@('[':_) = [ (TupleTy tys,rest)| (tys,rest) <- readList xs ]+ readsPrec _ what = error $ "read Type - can't parse: " ++ what++-------------------------------------------------------------------------+-- | 'StdLogicType' is the type for std_logic things,+-- typically input/output arguments to VHDL entities.+data StdLogicType+ = SL -- ^ std_logic+ | SLV Int -- ^ std_logic_vector (n-1 downto 0)+ | SLVA Int Int -- ^ std_logic_vector (n-1 downto 0) (m-1 downto 0)+ | G -- ^ generic (inward) argument+ deriving (Eq, Ord)++instance Show StdLogicType where+ show (SL) = "std_logic"+ show (SLV n) = "std_logic_vector(" ++ show (n-1) ++ " downto 0)"+ show (SLVA n m) = "std_logic_array_" ++ show n ++ "_" ++ show m+ show (G) = "generic"++-- | toStdLogic maps Lava Types to a StdLogicType+toStdLogicType :: Type -> StdLogicType+toStdLogicType B = SL+toStdLogicType ClkTy = SL+toStdLogicType (V n) = SLV n+toStdLogicType GenericTy = G+toStdLogicType (MatrixTy i ty) = SLVA i (fromIntegral size')+ where size' = typeWidth ty+toStdLogicType ty = SLV $ fromIntegral size'+ where size' = typeWidth ty++-- | fromStdLogic maps StdLogicTypes to Lava types.+fromStdLogicType :: StdLogicType -> Type+fromStdLogicType SL = B+fromStdLogicType (SLV n) = V n+fromStdLogicType (SLVA n m) = MatrixTy n (V m)+fromStdLogicType G = GenericTy++-------------------------------------------------------------------------+-- | Id is the name/tag of a block of compuation.+data Id = Prim String -- ^ built in thing+ | External String -- ^ VHDL entity+ | Function [(RepValue,RepValue)] -- ^ anonymous function++ | ClockId String -- ^ An environment box++ | Comment [String] -- ^ An identity; also a multi-line comments+ | BlackBox (Box Dynamic) -- ^ 'BlackBox' can be removed without harm+ -- The rule is you can only insert you own+ -- types in here (or use newtype).+ -- Prelude or other peoples types+ -- are not allowed (because typecase becomes ambigious)++ deriving (Eq, Ord)+++{-+ - List of prims+ id ::+ index :: M<n> -> ix -> n+ proj :: G<Int> ->+-}++instance Show Id where+ show (External nm) = '$':nm+ show (Prim nm) = nm+ show (ClockId nm) = '@':nm+-- show (UniqNm n) = "#" ++ show (hashUnique n) -- might not be uniq+ show (Function _) = "<fn>"+ show (BlackBox _) = "<bb>"+ show (Comment xs) = "{- " ++ show xs ++ " -}"++-- | Box wraps a dynamic, so that we can define custom Eq/Ord instances.+newtype Box a = Box a++-- I do not like this, but at least it is defined.+-- All black boxes are the same.+instance Eq (Box a) where { (==) _ _ = True }+instance Ord (Box a) where { compare _ _ = EQ }++-------------------------------------------------------------------------+++-- We tie the knot at the 'Entity' level, for observable sharing.++-- | An 'Entity' Entity is our central "BOX" of computation, round an 'Id'.+data Entity s = Entity Id [(String,Type)] [(String,Type,Driver s)]+ deriving (Show, Eq, Ord)++-- | entityFind finds an input in a list, avoiding the need to have ordering.+entityFind :: (Show a) => String -> Entity a -> (Type, Driver a)+entityFind nm e@(Entity _ _ ins) =+ case [ (t,p) | (nm',t,p) <- ins, nm == nm' ] of+ [] -> error $ "can not find : " ++ show nm ++ " in " ++ show e+ [x] -> x+ _ -> error $ "found multiple : " ++ show nm ++ " in " ++ show e+++instance T.Traversable Entity where+ traverse f (Entity v vs ss) =+ Entity v vs <$> T.traverse (\ (val,ty,a) -> (,,) val ty `fmap` T.traverse f a) ss++instance F.Foldable Entity where+ foldMap f (Entity _ _ ss) = mconcat [ F.foldMap f d | (_,_,d) <- ss ]++instance Functor Entity where+ fmap f (Entity v vs ss) = Entity v vs (fmap (\ (var,ty,a) -> (var,ty,fmap f a)) ss)+++-- | 'E' is the knot-tyed version of Entity.+newtype E = E (Entity E)+++-- You want to observe+instance MuRef E where+ type DeRef E = Entity+ mapDeRef f (E s) = T.traverse f s++instance Show E where+ show (E s) = show s++-- Consider this carefully+instance Eq E where+ (E s1) == (E s2) = s1 == s2++-------------------------------------------------------------------------+-- | A 'Driver' is a specific driven 'wire' (signal in VHDL),+-- which types contains a value that changes over time.+data Driver s = Port String s -- ^ a specific port on the entity+ | Pad String -- ^ an input pad+ | ClkDom String -- ^ the clock domain (the clock enable, resolved via context)+ | Lit RepValue -- ^ A representable Value (including unknowns, aka X in VHDL)+ | Generic Integer -- ^ A generic argument, always fully defined+ | Lits [RepValue] -- ^ A list of values, typically constituting a ROM initialization.+ | Error String -- ^ A call to err, in Datatype format for reification purposes+ deriving (Eq, Ord)++instance Show i => Show (Driver i) where+ show (Port v i) = "(" ++ show i ++ ")." ++ v+ show (Pad v) = show v+ show (ClkDom d) = '@':d+ show (Lit x) = "'" ++ show x ++ "'"+ show (Lits xs) = show (take 16 xs) ++ "..."+ show (Generic x) = show x+ show (Error msg) = show $ "Error: " ++ msg+-- show (Env' env) = "<env>"++instance T.Traversable Driver where+ traverse f (Port v s) = Port v <$> f s+ traverse _ (Pad v) = pure $ Pad v+ traverse _ (ClkDom d) = pure $ ClkDom d+-- traverse _ (PathPad v) = pure $ PathPad v+ traverse _ (Lit i) = pure $ Lit i+ traverse _ (Lits vals) = pure $ Lits vals+ traverse _ (Generic i) = pure $ Generic i+ traverse _ (Error s) = pure $ Error s+-- traverse _ (Env' env) = pure $ Env' env++instance F.Foldable Driver where+ foldMap f (Port _ s) = f s+ foldMap _ (Pad _) = mempty+ foldMap _ (ClkDom _) = mempty+-- foldMap _ (PathPad _) = mempty+ foldMap _ (Lit _) = mempty+ foldMap _ (Lits _) = mempty+ foldMap _ (Generic _) = mempty+ foldMap _ (Error _) = mempty++instance Functor Driver where+ fmap f (Port v s) = Port v (f s)+ fmap _ (Pad v) = Pad v+ fmap _ (ClkDom d) = ClkDom d+-- fmap _ (PathPad v) = PathPad v+ fmap _ (Lit i) = Lit i+ fmap _ (Lits vals) = Lits vals+ fmap _ (Generic i) = Generic i+ fmap _ (Error s) = Error s+++-- A 'D' is a "Deep", phantom-typed driver into an Entity or Entity+-- | The 'D' type adds a phantom type to a driver.+newtype D a = D { unD :: Driver E } deriving Show++---------------------------------------------------------------------------------------------------------+-- | class 'Clock' is a type that can be be used to represent a clock.+class Clock clk where {}++-- | generic/default/board/standard/vanilla clock.+data CLK+instance Clock CLK where {}++---------------------------------------------------------------------------------------------------------+-- | A RepValue is a value that can be represented using a bit encoding. The+-- least significant bit is at the front of the list.+newtype RepValue = RepValue { unRepValue :: [Maybe Bool] }+ deriving (Eq, Ord)++instance Show RepValue where+ show (RepValue vals) = "0b" +++ [ case v of+ Nothing -> 'X'+ Just True -> '1'+ Just False -> '0'+ | v <- reverse vals+ ]++instance Read RepValue where+ readsPrec _ ('0':'b':xs)+ = [ (RepValue [ case c of+ 'X' -> Nothing+ 'U' -> Nothing+ '0' -> Just False+ '1' -> Just True+ v -> error $ "Can't read RepValue " ++ show v+ | c <- reverse cs+ ]+ ,rest)]+ where (cs,rest) = span (`elem` "01XU") xs+ readsPrec _ other = error $ "Can't read RepValue " ++ show other++showRepValue :: Type -> RepValue -> String+showRepValue (TupleTy tys) (RepValue vals) = + "(" ++ concat [ sep ++ showRepValue ty (RepValue (take (typeWidth ty) (drop len vals)))+ | (ty,len,sep) <- zip3 tys lens' ("" : repeat ",")+ ] ++ ")"+ where+ lens = map typeWidth tys+ lens' = 0 : zipWith (+) lens' lens+showRepValue (MatrixTy i ty) (RepValue vals) = + "[" ++ concat [ sep ++ showRepValue ty (RepValue (take (typeWidth ty) (drop len vals)))+ | (len,sep) <- take i $ zip lens' ("" : repeat ",")+ ] ++ "]"+ where+ lens = map typeWidth (replicate i ty)+ lens' = 0 : zipWith (+) lens' lens+showRepValue ty repValue | isValidRepValue repValue = case ty of+ B -> case vals of+ [True] -> "high"+ [False] -> "low"+ _ -> sizeError+ S n | n == length vals -> show signed_number+ S _ | otherwise -> sizeError+ U n | n == length vals -> show number+ U _ | otherwise -> sizeError+ V n | n == length vals -> show repValue+ V _ | otherwise -> sizeError++ -- We should reconsider the other cases+ _ -> show repValue+ where+ sizeError = error $ "size error with " ++ show repValue ++ " (ty = " ++ show ty ++ ")"+ Just vals = getValidRepValue repValue+ number :: Integer+ number = sum [ n+ | (n,True) <- zip (iterate (*2) 1) vals+ ]++ signed_number :: Integer+ signed_number = sum + [ n+ | (n,True) <- zip (iterate (*2) 1) (init vals)+ ] * if last vals then (-1) else 1+ + +-- Show the structure if there are *any* value bits.+showRepValue _ty repValue@(RepValue xs)+ | any isJust xs = show repValue+-- Otherwise, just show ?+showRepValue _ty _repValue = "?"++-- | 'appendRepValue' joins two 'RepValue'; the least significant value first.+-- TODO: reverse this!+appendRepValue :: RepValue -> RepValue -> RepValue+appendRepValue (RepValue xs) (RepValue ys) = RepValue (xs ++ ys)+++-- | 'isValidRepValue' checks to see is a 'RepValue' is completely valid.+isValidRepValue :: RepValue -> Bool+isValidRepValue (RepValue m) = and $ fmap isGood m+ where+ isGood :: Maybe Bool -> Bool+ isGood Nothing = False+ isGood (Just {}) = True++-- | 'getValidRepValue' Returns a binary rep, or Nothing is *any* bits are 'X'.+getValidRepValue :: RepValue -> Maybe [Bool]+getValidRepValue r@(RepValue m)+ | isValidRepValue r = Just $ fmap f m+ | otherwise = Nothing+ where f (Just v) = v+ f Nothing = error "Can't get the value of an unknown wire."+++-- | 'chooseRepValue' turns a RepValue with (optional) unknow values,+-- and chooses a representation for the RepValue.+chooseRepValue :: RepValue -> RepValue+chooseRepValue (RepValue xs) = RepValue $ map f xs+ where+ f Nothing = Just False+ f other = other++-- | 'cmpRepValue' compares a golden value with another value, returning the bits that are different.+-- The first value may contain 'X', in which case *any* value in that bit location will+-- match. This means that 'cmpRepValue' is not commutative.+cmpRepValue :: RepValue -> RepValue -> Bool+cmpRepValue (RepValue gs) (RepValue vs)+ | length gs == length vs+ = and $ zipWith (\ g v ->+ case (g,v) of+ (Nothing,_) -> True+ (Just True,Just True) -> True+ (Just False,Just False) -> True+ _ -> False) gs vs+cmpRepValue _ _ = False++---------------------------------------------------------------------------------------------------------+-- BitPat is a small DSL for writing bit-patterns.+-- It is bit-endian, unlike other parts of KL.+-- It is also a sized version of RepValue.++data BitPat w = BitPat { bitPatToRepValue :: RepValue }+ deriving (Eq, Ord, Show)++-- | '&' is a sized append for BitPat.+infixl 6 &+(&) :: (Size w1, Size w2, Size w, w ~ ADD w1 w2, w1 ~ SUB w w2, w2 ~ SUB w w1)+ => BitPat w1 -> BitPat w2 -> BitPat w+(BitPat a) & (BitPat b) = BitPat (appendRepValue b a)++instance (Size w) => Num (BitPat w) where+ (+) = error "(+) undefined for BitPat"+ (*) = error "(*) undefined for BitPat"+ abs = error "abs undefined for BitPat"+ signum = error "signum undefined for BitPat"+ fromInteger n+ | n >= 2^(size (error "witness" :: w))+ = error $ "fromInteger: out of range, value = " ++ show n+ | otherwise+ = BitPat $ RepValue+ $ take (size (error "witness" :: w))+ $ map (Just . odd)+ $ iterate (`div` (2::Integer))+ $ n++instance (Size w) => Real (BitPat w) where+ toRational n = toInteger n % 1++instance (Size w) => Enum (BitPat w) where+ toEnum = fromInteger . fromIntegral+ fromEnum p = case bitPatToInteger p of+ Nothing -> error $ "fromEnum failure: " ++ show p+ Just i -> fromIntegral i+instance (Size w) => Integral (BitPat w) where+ quotRem = error "quotRem undefined for BitPat"+ toInteger p = case bitPatToInteger p of+ Nothing -> error $ "toInteger failure: " ++ show p+ Just i -> i++bitPatToInteger :: BitPat w -> Maybe Integer+bitPatToInteger (BitPat rv) = case getValidRepValue rv of+ Nothing -> Nothing+ Just xs -> return $+ sum [ n+ | (n,b) <- zip (iterate (* 2) 1)+ xs+ , b+ ]++instance IsString (BitPat w) where+ fromString = bits++bits :: String -> BitPat w+bits = BitPat . RepValue . map f . reverse+ where+ f '0' = return False+ f '1' = return True+ f 'X' = Nothing+ f '_' = Nothing+ f '-' = Nothing+ f o = error $ "bit pattern, expecting one of 01X_-, found " ++ show o++bool :: BitPat X1 -> Bool+bool (BitPat (RepValue [Just b])) = b+bool other = error $ "bool: expecting bool isomophism, found: " ++ show other++every :: forall w . (Size w) => [BitPat w]+every = [ BitPat $ RepValue (fmap Just count) | count <- counts n ]+ where+ n = size (error "witness" :: w)+ counts :: Int -> [[Bool]]+ counts 0 = [[]]+ counts num = [ x : xs | xs <- counts (num-1), x <- [False,True] ]++---------------------------------------------------------------------------------------------------------+-- | 'KLEG' (Kansas Lava Entity Graph) is our primary way of representing a graph of entities.+data KLEG = KLEG+ { theCircuit :: [(Unique,Entity Unique)]+ -- ^ This the main graph. There is no actual node for the source or sink.+ , theSrcs :: [(String,Type)]+ -- ^ this is a (convenience) list of the src values.+ , theSinks :: [(String,Type,Driver Unique)]+ -- ^ these are the sinks; all values are generated from here.+ }+++instance Show KLEG where+ show rCir = msg+ where+ showDriver d t = show d ++ " : " ++ show t++ bar = replicate 78 '-' ++ "\n"++ circInputs = unlines+ [ show var ++ " : " ++ show ty+ | (var,ty) <- sort $ theSrcs rCir+ ]++ circOutputs = unlines+ [ show var ++ " <- " ++ showDriver dr ty+ | (var,ty,dr) <- sort $ theSinks rCir+ ]++ circuit = unlines+ [ case e of+ Entity nm outs ins ->+ "(" ++ show uq ++ ") " ++ show nm ++ "\n"+ ++ unlines [ " out " ++ v ++ ":" ++ show ty | (v,ty) <- outs ]+ ++ unlines [ " in " ++ v ++ " <- " ++ showDriver dr ty | (v,ty,dr) <- ins ]+ ++ unlines [ " case " ++ show x ++ " -> " ++ show y+ | (Function pairs) <- [nm]+ , (x,y) <- pairs+ ]+ | (uq,e) <- theCircuit rCir+ ]++ msg = bar+ ++ "-- Inputs --\n"+ ++ bar+ ++ circInputs+ ++ bar+ ++ "-- Outputs --\n"+ ++ bar+ ++ circOutputs+ ++ bar+ ++ "-- Entities --\n"+ ++ bar+ ++ circuit+ ++ bar++-- | Map a function across all of the entities in a KLEG, accumulating the results in a list.+visitEntities :: KLEG -> (Unique -> Entity Unique -> Maybe a) -> [a]+visitEntities cir fn =+ [ a+ | (u,m) <- theCircuit cir+ , Just a <- [fn u m]+ ]++-- | Map a function across a KLEG, modifying each Entity for which the function+-- returns a Just. Any entities that the function returns Nothing for will be+-- removed from the resulting KLEG.+mapEntities :: KLEG -> (Unique -> Entity Unique -> Maybe (Entity Unique)) -> KLEG+mapEntities cir fn = cir { theCircuit =+ [ (u,a)+ | (u,m) <- theCircuit cir+ , Just a <- [fn u m]+ ] }++-- | Generate a list of Unique ids that are guaranteed not to conflict with any+-- ids already in the KLEG.+allocEntities :: KLEG -> [Unique]+allocEntities cir = [ highest + i | i <- [1..]]+ where+ highest = maximum (0 : visitEntities cir (\ u _ -> return u))++-- | A 'Signature' is the structure-level type of a KLEG.+data Signature = Signature+ { sigInputs :: [(String,Type)]+ , sigOutputs :: [(String,Type)]+ , sigGenerics :: [(String,Integer)]+ }+ deriving (Show, Read, Eq)++-- | Calculate a signature from a KLEG.+circuitSignature :: KLEG -> Signature+circuitSignature cir = Signature+ { sigInputs = theSrcs cir+ , sigOutputs = [ (v,t) | (v,t,_) <- theSinks cir ]+ , sigGenerics = [] -- TODO: fix this+ }++-------------------------------------------------------------------------------------+-- | Create a type witness, to help resolve some of the type issues.+-- Really, we are using this in a system-F style.+-- (As suggested by an anonymous TFP referee, as a better alternative to using 'error "witness"').+data Witness w = Witness++----------------------------------------------------------------------------++-- | Select the shallow embedding from one circuit, and the deep embedding from another.+class Dual a where+ -- | Take the shallow value from the first argument, and the deep value from the second.+ dual :: a -> a -> a++instance (Dual a, Dual b) => Dual (a,b) where+ dual (a1,b1) (a2,b2) = (dual a1 a2,dual b1 b2)++instance (Dual a, Dual b,Dual c) => Dual (a,b,c) where+ dual (a1,b1,c1) (a2,b2,c2) = (dual a1 a2,dual b1 b2,dual c1 c2)++instance (Dual b) => Dual (a -> b) where+ dual f1 f2 x = dual (f1 x) (f2 x)+++----------------------------------------------------------------------------+-- Our version of tuples, with a right leaning (aka lists).+infixr 5 :>+-- | Alternative definition for (,). Constructor is right-associative.+data a :> b = a :> b deriving (Eq, Ord, Show, Read)+++----------------------------------------------------------------------------+-- | How to balance our circuits. Typically use 'Sweet'(spot), but+-- 'Small' has permission to take longer, and 'Fast' has permission+-- use extra gates.++data Synthesis = Small | Sweet | Fast+
+ Language/KansasLava/Utils.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeFamilies, ParallelListComp, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, RankNTypes #-}+-- | This module contains a number of primitive circuits, and instance+-- definitions for standard type classes for circuits.+module Language.KansasLava.Utils where++import Control.Monad+import Data.Bits++import Language.KansasLava.Rep+import Language.KansasLava.Signal+--import Language.KansasLava.Signal+-- import Language.KansasLava.Interp+import qualified Language.KansasLava.Stream as S+import Language.KansasLava.Types++import Data.Sized.Matrix as M+import Data.Sized.Signed as SI++-----------------------------------------------------------------------------------------------++-- | The 'Signal' representing True.+high :: (sig ~ Signal i) => sig Bool+high = pureS True++-- | The 'Signal' representing False.+low :: (sig ~ Signal i) => sig Bool+low = pureS False++{-+-- | The constant combinational values for True.+true :: Comb Bool+true = high++-- | The constant combinational values for False.+false :: Comb Bool+false = low+-}++-----------------------------------------------------------------------------------------------+-- | 1-bit and gate.+and2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+and2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of+ (Just True,Just True) -> optX $ Just True+ (Just False,_) -> optX $ Just False+ (_,Just False) -> optX $ Just False+ _ -> optX $ Nothing) "and2"+ s1+ s2++-- | 1-bit or gate.+or2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+or2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of+ (Just False,Just False) -> optX $ Just False+ (Just True,_) -> optX $ Just True+ (_,Just True) -> optX $ Just True+ _ -> optX $ Nothing ) "or2"+ s1+ s2++-- | 1-bit xor gate.+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"+ s1+ s2++-- | 1-bit nand gate.+nand2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+nand2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of+ (Just True,Just True) -> optX $ Just False+ (Just False,_) -> optX $ Just True+ (_,Just False) -> optX $ Just True+ _ -> optX $ Nothing) "nand2"+ s1+ s2++-- | 1-bit nor gate.+nor2 :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+nor2 s1 s2 = primXS2 (\ a b -> case (unX a,unX b) of+ (Just False,Just False) -> optX $ Just True+ (Just True,_) -> optX $ Just False+ (_,Just True) -> optX $ Just False+ _ -> optX $ Nothing ) "nor2"+ s1+ s2+++-- | 1 bit inverter.+bitNot :: ( sig ~ Signal i) => sig Bool -> sig Bool+bitNot s1 = primS1 not "not" s1++-- | Extract the n'th bit of a signal that can be represented as Bits.+testABit :: forall a i w sig . (Bits a, Rep a, Size w, Rep w, w ~ (W a), sig ~ Signal i)+ => sig a -> sig w -> sig Bool+testABit sig0 ix = sig1 .!. ix+ where+ sig1 :: sig (Matrix w Bool)+ sig1 = (bitwise) sig0++{-+ - old test-a-bit+testABit :: forall sig a i . (Bits a, Rep a, sig ~ Signal i) => sig a -> Int -> sig Bool+testABit (Signal a ae) i = Signal (fmap (liftX (flip testBit i)) a)+ (entityD2 "testBit" ae+ (pureD (i :: Int)))+-}++-- | Predicate to see if a Signed value is positive.+isPositive :: forall sig i ix . (sig ~ Signal i, Size ix, Integral ix, Rep ix) => sig (Signed ix) -> sig Bool+isPositive a = bitNot $ testABit a (fromIntegral msb)+ where msb = bitSize a - 1++infixr 3 .&&.+infixr 2 .||.+infixr 2 .^.++-- | Alias for 'and2'.+(.&&.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+(.&&.) = and2++-- | Alias for 'or2'.+(.||.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+(.||.) = or2++-- | Alias for 'xor2'.+(.^.) :: ( sig ~ Signal i) => sig Bool -> sig Bool -> sig Bool+(.^.) = xor2++++-----------------------------------------------------------------------------------------------+-- Map Ops+++-- Assumping that the domain is finite (beacause of Rep), and *small* (say, < ~256 values).++-- | Given a function over a finite domain, generate a ROM representing the+-- function. To make this feasible to implement, we assume that the domain is+-- small (< 2^8 values).+funMap :: forall sig a b i . (sig ~ Signal i, Rep a, Rep b) => (a -> Maybe b) -> sig a -> sig b+funMap fn (Signal a ae) = mustAssignSLV $ Signal (fmap fn' a)+ (D $ Port ("o0")+ $ E+ $ Entity (Prim "asyncRead")+ [("o0",tB)]+ [ ("i0",tMB,rom)+ , ("i1",tA,unD ae)+ ])++ where tA = repType (Witness :: Witness a)+ tB = repType (Witness :: Witness b)+ tMB = MatrixTy (Prelude.length all_a_bitRep) tB++ undefB = unknownRepValue (Witness :: Witness b)++ fn' a' = case unX a' of+ Nothing -> optX Nothing+ Just v -> optX (fn v)++ all_a_bitRep :: [RepValue]+ all_a_bitRep = allReps (Witness :: Witness a)++ rom = Port "o0" $ E $ Entity (Prim "rom") [("o0",tMB)] [("defs",RomTy (Prelude.length all_a_bitRep),Lits lits)]++ -- assumes in order table generation+ lits :: [RepValue]+ lits = [ case unX (fromRep w_a) of+ Nothing -> undefB+ Just a' -> case fn a' of+ Nothing -> undefB+ Just b -> toRep (pureX b)+ | w_a <- all_a_bitRep+ ]+++++-----------------------------------------------------------------------------------------------++-- | Multiplexer with a 1-bit selector and arbitrary width data inputs.+-- zero (false) selects the first argument of the tuple, one (true)+-- selects the second.+mux :: forall sig a i . ( sig ~ Signal i, Rep a) => sig Bool -> (sig a,sig a) -> sig a+mux iSig (fSig,tSig) = primXS3 muxShallow "mux" iSig fSig tSig++-- | Shallow definition of a multiplexer. Deals with 3-value logic.+muxShallow :: forall a . (Rep a) => X Bool -> X a -> X a -> X a+muxShallow i f t =+ case unX i of+ Nothing -> optX Nothing+ Just True -> t+ Just False -> f++++-------------------------------------------------------------------------------------------------+-- | TODO: Document this. And move it.+eval :: forall a . (Rep a) => a -> ()+eval a = count $ unRepValue $ toRep (optX (Just a))+ where count (Just True:rest) = count rest+ count (Just False:rest) = count rest+ count (Nothing:rest) = count rest+ count [] = ()++-- | TODO: Document this.+evalX :: forall a . (Rep a) => X a -> ()+evalX a = count $ unRepValue $ toRep a+ where count (Just True:rest) = count rest+ count (Just False:rest) = count rest+ count (Nothing:rest) = count rest+ count [] = ()+++-------------------------------------------------------------------------------------------------++-- | Alias for '.!.'+muxMatrix+ :: forall sig x a i+ . ( sig ~ Signal i, Size x, Rep x, Rep a)+ => sig (Matrix x a)+ -> sig x+ -> sig a+muxMatrix = (.!.)++-- | Extract the n'th element of a vector.+(.!.) :: forall sig x a i+ . ( sig ~ Signal i, Size x, Rep x, Rep a)+ => sig (Matrix x a)+ -> sig x+ -> sig a+(.!.) mSig xSig = primS2 (flip (M.!)) "index" xSig mSig+ -- order reversed on purpose++-------------------------------------------------------------------------------------------------++-- | Lift a (named) binary function over bools to be over 'Signal's.+boolOp :: forall a i sig . (Rep a, sig ~ Signal i) => (a -> a -> Bool) -> String -> sig a -> sig a -> sig Bool+boolOp fn nm a b = primS2 fn nm a b++infix 4 .==., .>=., .<=., .<., .>.++-- | N-bit equality.+(.==.) :: forall a i sig . (Rep a, Eq a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(.==.) = boolOp (==) ".==."++-- | N-bit not-equals.+(./=.) :: forall a i sig . (Rep a, Eq a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(./=.) xs ys = bitNot (xs .==. ys) -- TODO: consider making this a primitive++-- | N-bit greater-than-or-equals.+(.>=.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(.>=.) = boolOp (>=) ".>=."++-- | N-bit less-than-or-equals.+(.<=.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(.<=.) = boolOp (<=) ".<=."++-- | N-bit less-than.+(.<.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(.<.) = boolOp (<) ".<."++-- | N-bit greater-than.+(.>.) :: forall a i sig . (Rep a, Ord a, sig ~ Signal i) => sig a -> sig a -> sig Bool+(.>.) = boolOp (>) ".>."+++-------------------------------------------------------------------------------++{-++-- This is the funny one, needed for our application+--instance (Enum ix, Size ix, Integral m, Size m) => StdLogic (Sampled.Sampled m ix) where+-- type WIDTH (Sampled.Sampled m ix) = m++-- Move this to a better place.++-------------------------------------------------------------------------------------+++{-+ , sig ~ Signal i, Rep a2, Rep a1+ , StdLogic a, StdLogic a1, StdLogic a2) => sig a -> sig (a1,a2)+factor a = pack ( fromStdLogicVector $ extractStdLogicVector 0 vec+ , fromStdLogicVector $ extractStdLogicVector (size (error "witness" :: WIDTH a1)) vec+ )+ where vec :: sig (StdLogicVector (WIDTH a))+ vec = toStdLogicVector a+-}++-------------------------------------------------------------------------------------+-}++-- | The identity function, lifted to 'Signal's.+lavaId :: ( sig ~ Signal i, Rep a) => sig a -> sig a+lavaId a = primS1 id "id" a++++-------------------------------------------------------------------------------------++-- | 'ignoring' is used to make sure a value is reified.+-- TODO: is this used?+ignoring :: ( sig ~ Signal i, Rep a, Rep b) => sig a -> sig b -> sig a+ignoring a b = primS2 const "const" a b+++-------------------------------------------------------------------------------------++-- | Given a representable value for a discirminant and a list of input signals, generate a n-ary mux.+cASE :: (Rep b, sig ~ Signal i) => [(sig Bool,sig b)] -> sig b -> sig b+cASE [] def = def+cASE ((p,e):pes) def = mux p (cASE pes def, e)+++-------------------------------------------------------------------------------------+++-- | translate using raw underlying bits, Width *must* be the same.+bitwise :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b, W a ~ W b) => sig a -> sig b+bitwise a = primXS1 (fromRep . toRep) "coerce" a++-- | translate using raw underlying bits for deep, but given function for shallow, Width *must* be the same.+coerce :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b, W a ~ W b) => (a -> b) -> sig a -> sig b+coerce f a = primXS1 g "coerce" a+ where+ g :: X a -> X b+ g x = y'+ where+ y = optX $ liftM f $ unX x+ y' | toRep x == toRep y = y+ | otherwise = error "coerce fails to preserve bit pattern"+++-- | Coerce a value from on type to another, interpreting the bits as a signed+-- value. Do not sign extend.+signedX :: forall a b . (Rep a, Rep b) => X a -> X b+signedX = id+ . fromRep+ . RepValue+ . (\ m -> take (repWidth (Witness :: Witness b)) (m ++ repeat (last m))) -- not signed extended!+ . unRepValue+ . toRep+++-- | consider the bits as signed number (sign extend)+signed :: (Rep a, Rep b, Num b, sig ~ Signal i) => sig a -> sig b+signed a = primXS1 signedX "signed" a++-- | Consider the value as an unsigned value.+unsignedX :: forall a b . (Rep a, Rep b) => X a -> X b+unsignedX = id+ . fromRep+ . RepValue+ . (\ m -> take (repWidth (Witness :: Witness b)) (m ++ repeat (Just False))) -- not signed extended!+ . unRepValue+ . toRep++-- | consider the bits an unsigned number (zero extend)+unsigned :: (Rep a, Rep b, Num b, sig ~ Signal i) => sig a -> sig b+unsigned a = primXS1 unsignedX "unsigned" a++--overStdLogic++--generalToStd :: (Rep a, Rep b, sig ~ Signal i) => sig a -> sig b+--generalToStd a = primXS1 (fromRep . toRep) "coerce" a++-- | force the representation of the incoming argument to be a StdLogicVector.+-- Assumes the argument is an entity; a real hack.+-- We need a type checking pass, instead.+mustAssignSLV :: (Rep a, sig ~ Signal i) => sig a -> sig a+mustAssignSLV (Signal a (D (Port "o0" (E (Entity (Prim nm) [("o0",tA)] inps)))))+ = res+ where+ res = Signal a (D coer)++ coer = Port "o0" (E (Entity (Prim "coerce") [("o0",tA)] [("i0",V width,new)]))+ new = Port "o0" (E (Entity (Prim nm) [("o0",V width)] inps))++ width = typeWidth tA+mustAssignSLV _ = error "mustAssignSLV: internal error"++---------------------------------------------------------------------------+-- | translate using raw underlying bits, type *must* be the same, but is not statically checked.+unsafeId :: forall sig a b i . ( sig ~ Signal i, Rep a, Rep b) => sig a -> sig b+unsafeId a = primXS1 (fromRep . toRep) "coerce" a++----------------------------------------------------------------------------+-- | given a signal of a1 + a2 width, yield a signal with a pair of values of width a1 and a2 respectively.+unappendS :: forall a a1 a2 sig clk . ( sig ~ Signal clk, Rep a, Rep a1, Rep a2, W a ~ ADD (W a1) (W a2)) => sig a -> (sig a1, sig a2)+unappendS a = unpack (bitwise a :: sig (a1,a2))++-- | given two signals of a1 and a2 width, respectively, pack them into a signal of a1 + a2 width.+appendS :: forall sig a b c clk . ( sig ~ Signal clk, Rep a, Rep b, Rep c, W c ~ ADD (W a) (W b)) => sig a -> sig b -> sig c+appendS x y = bitwise (pack (x,y) :: sig (a,b))+++----------------------------------------------------------------------------+-- | The first argument is the value is our value under test;+-- the second is our reference value.+-- If the reference is undefined, then the VUT *can* also be under test.+-- This only works for shallow circuits, and is used when creating test benches.++-- TODO: this is an internal thing. We need an internals module.++refinesFrom :: forall sig a i . (Clock i, sig ~ Signal i, Rep a) => sig a -> sig a -> sig Bool+refinesFrom a b = mkShallowS (S.zipWith fn (shallowS a) (shallowS b))+ where+ fn a' b' = let res = and [ case (vut,ref) of+ (_,Nothing) -> True+ (Just x,Just y) -> x == y+ _ -> False+ | (vut,ref) <- zip (unRepValue (toRep a'))+ (unRepValue (toRep b'))+ ]+ in optX (Just res)++--------------------------------------------------------------------------------+-- | Create a register, pass the output of the register through some+-- combinational logic, then pass the result back into the register input.+iterateS :: (Rep a, Clock c, seq ~ Signal c)+ => (forall j . Signal j a -> Signal j a)+ -> a -> seq a+iterateS f start = out where+ out = register start (f out)++---------------------------------------------------------------------++-- 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 a = mux (a .==. maxBound) (a + 1, pureS 0)++loopingDecS :: (Bounded a, Num a, Rep a, sig ~ Signal i) => sig a -> sig a+loopingDecS a = mux (a .==. 0) (a - 1, pureS maxBound)+
+ Language/KansasLava/VCD.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+-- | This module contains functions for generating VCD debug traces.+-- It also provides functionality for (de)serializing Traces.+module Language.KansasLava.VCD+ ( VCD(..)+ , writeVCDFile+ , readVCDFile+ , addEvent+ -- * Generate a Signature from a VCD trace+ , toSignature+ , fromSignature+ -- * Compare two VCDs+ , cmpVCD+ , ioOnly+ -- * Make a VCD trace from a Fabric and input Pads+ , mkVCD+ , mkVCDCM+ -- * Reading and Writing the Test Bench Format (.tbf)+ , readTBF+ , writeTBF+ -- * Convert Rep to Test Bench Word+ , tbw2rep+ , rep2tbw+ ) where++import Language.KansasLava.Fabric+import Language.KansasLava.Rep+import Language.KansasLava.Signal+import Language.KansasLava.Types+import Language.KansasLava.Internal+import qualified Language.KansasLava.VCD.EventList as E++import qualified Language.KansasLava.Stream as S++import Control.Monad++import Data.Char+import qualified Data.Foldable as F+import Data.Function+import Data.List+import qualified Data.Map as M++----------------------------------------------------------------------------------------+-- | The VC (value change) is used for capturing traces of shallow-embedded+-- streams. It combines the bitwise representation of a stream along with the+-- type of the stream.+data VC = VC Type (E.EventList RepValue)+ deriving (Eq, Ord, Read, Show)++addVC :: VC -> Int -> RepValue -> VC+addVC (VC ty el) i v = VC ty $ E.insert (i,v) el++newVC :: forall w . (Rep w) => Witness w -> VC+newVC _ = VC (repType (Witness :: Witness w)) $ E.fromList []++-- | Convert a Pad to a Tracestream+padToVC :: Int -> Pad -> VC+padToVC c (StdLogic s) = convertVC $ take c $ S.toList $ shallowS s+padToVC c (StdLogicVector s) = convertVC $ take c $ S.toList $ shallowS s+padToVC _ other = error $ "fix padToVC for " ++ show other++-- | Convert a Stream to a VC. Note this can force evaluation.+convertVC :: forall w . (Rep w) => [X w] -> VC+convertVC l = VC ty $ E.fromList $ map toRep l+ where (VC ty _) = newVC (Witness :: Witness w)++----------------------------------------------------------------------------------------+-- | 'VCD' is a primary bit-wise record of an interactive session with some circuit+-- Map from module/name to stream.+newtype VCD = VCD [(String,VC)]+ deriving (Eq)++instance Show VCD where+ show (VCD m) = headers ++ "\n" ++ E.foldrWithTime (\(clk,str) r -> pr (show clk) clkwidth str ++ "\n" ++ r) "" rows+ where wMaxLens :: [E.EventList (String,Int)]+ wMaxLens = [ let maxlen = max $ length h+ in fmap (\v -> let str = showRepValue ty v in (str, maxlen $ length str)) el+ | (h, VC ty el) <- m ]++ rows = fmap fst+ $ E.mergeWith (\(s1,l1) (s2,l2) -> (pr s1 l1 s2, l1 + l2))+ wMaxLens++ clkwidth = max 3 $ length $ show $ E.length rows++ widths = map (snd . E.head) wMaxLens+ headers = foldr (\(h,l) r -> pr h l r) "" $ zip ("clk" : map fst m) (clkwidth : widths)++ pr s1 l1 s2 = s1 ++ replicate (1 + l1 - length s1) ' ' ++ s2++addEvent :: forall w . (Rep w) => String -> Int -> (X w) -> VCD -> VCD+addEvent nm i v (VCD m) | nm `elem` map fst m = VCD [ (n,if n == nm then addVC vc i (toRep v) else vc) | (n,vc) <- m ]+ | otherwise = VCD $ (nm, addVC (newVC (Witness :: Witness w)) i (toRep v)) : m++-- | Generate a signature from a trace.+-- TODO: support generics in both these functions?+toSignature :: VCD -> Signature+toSignature vcd = Signature (convert $ inputs vcd) (convert $ outputs vcd) []+ where convert m = [ (dropModName nm,ty) | (nm,VC ty _) <- m ]+ dropModName = reverse . takeWhile (/= '/') . reverse++-- | Creates an (empty) trace from a signature+fromSignature :: Signature -> VCD+fromSignature (Signature inps outps _) = VCD $ convert "inputs" inps ++ convert "outputs" outps+ where convert mnm l = [ (mnm ++ "/" ++ nm, VC ty $ E.fromList []) | (nm, ty) <- l ]++scope :: String -> VCD -> [(String,VC)]+scope s = scopes [s]++scopes :: [String] -> VCD -> [(String,VC)]+scopes s (VCD m) = [ (nm,ts) | (nm,ts) <- m+ , s' <- s+ , s' `isPrefixOf` nm ]++inputs :: VCD -> [(String,VC)]+inputs = scope "inputs"++outputs :: VCD -> [(String,VC)]+outputs = scope "outputs"++----------------------------------------------------------------------------------------++-- | Convert a VCD file to a VCD object.+readVCDFile :: FilePath -> Signature -> IO VCD+readVCDFile fileName sig = do+ vcd <- readFile fileName++ let (signames, ls) = defs2map $ dropWhile (not . isPrefixOf "$var") $ lines $ trimWhile isSpace vcd+ vals = uncurry changes . dumpvars $ ls+ streams = [ (nm, vs) | (i, nm) <- signames, (i',vs) <- vals, i == i' ]++ return $ VCD $ [ ("inputs/" ++ nm, VC ty s)+ | (nm,ty) <- sigInputs sig, (snm,s) <- streams, nm == snm ]+ ++ [ ("outputs/" ++ nm, VC ty s)+ | (nm,ty) <- sigOutputs sig, (snm, s) <- streams, nm == snm ]++-- | Parse definitions section, getting map of VCDIDs to signal names.+defs2map :: [String] -> ([(VCDID,String)],[String])+defs2map = go []+ where go m (l:ls) | head ws == "$enddefinitions" = (m,ls)+ | head ws == "$var" = go ((ws !! 3, trimWhile (== '"') $ ws !! 4):m) ls+ | otherwise = error "defs2map: parse error!"+ where ws = words l+ go _ _ = error "defs2map: parse error, no lines!"++trimWhile :: (Char -> Bool) -> String -> String+trimWhile p = f . f+ where f = reverse . dropWhile p++-- | Parse $dumpvars section, getting initial values for each signal.+dumpvars :: [String] -- ^ remaining lines of the vcd file+ -> ([(VCDID,RepValue)],[String]) -- ^ map of vcdIds to initial values+dumpvars ("$dumpvars":ls) = go ls []+ where go ("$end":rest) m = (m,rest)+ go (line:rest) m = let (vcdId,val) = parseVal line+ (m',rest') = go rest m+ in ((vcdId,val):m',rest')+ go [] _ = error $ "dumpvars: no $end!"+dumpvars other = error $ "dumpvars: bad parse! " ++ show other++-- | Parse list of changes into an EventList+changes :: [(VCDID,RepValue)] -> [String] -> [(String, E.EventList RepValue)]+-- changes initVals ls = foldl fromEvList [ (i,[(0,v)]) | (i,v) <- initVals ]+changes initVals ls = M.toList $ unMerge elist+ where (_,elist) = foldl go (0,E.fromList []) ls++ go :: (Int,E.EventList (String, RepValue)) -> String -> (Int,E.EventList (String, RepValue))+ go (_,el) ('#':time) = (read time, el)+ go (t,el) line = (t, E.insert (t, parseVal line) el)++ unMerge :: (E.EventList (String,RepValue)) -> M.Map String (E.EventList RepValue)+ unMerge = E.foldrWithTime f $ M.fromList [ (i,E.fromList [v]) | (i,v) <- initVals ]+ where f (i,(nm,v)) m | M.member nm m = M.adjust (E.insert (i,v)) nm m+ | otherwise = M.insert nm (E.singleton (i,v)) m++parseVal :: String -> (String, RepValue)+parseVal = go . words+ where go [bitVal] | length bitVal > 1 = (tail bitVal, tbw2rep $ take 1 bitVal)+ go [t:vals,ident] | t `elem` "bB" = (ident , tbw2rep vals )+ go other = error $ "parseVal: can't parse! " ++ unwords other++----------------------------------------------------------------------------------------++-- | Convert a 'VCD' to a VCD file.+writeVCDFile :: Bool -- ^ Whether to include the clock signal in the list of signals+ -> Integer -- ^ Timescale in nanoseconds+ -> FilePath -- ^ name of VCD file+ -> VCD+ -> IO ()+writeVCDFile _incClk ts fileName (VCD m) = writeFile fileName $ unlines+ [ "$version\n Kansas Lava\n$end"+ , "$timescale " ++ show ts ++ "ns $end"+ , "$scope module top $end"+ ]+ ++ unlines [ unwords ["$var wire", show $ typeWidth ty, ident, show k, "$end"]+ | (ident,(k,VC ty _)) <- signals ]+ ++ "$enddefinitions $end\n"+ ++ values [ (i',strm) | (i',(_,VC _ strm)) <- signals ]++ where signals = zip vcdIds m++type VCDID = String+-- VCD uses a compressed identifier naming scheme. This CAF generates the identifiers.+vcdIds :: [VCDID]+vcdIds = map code [0..]+ where code :: Int -> VCDID+ code i | i < 0 = ""+ code i = chr (33 + mod i 94) : code (div i 94 - 1)++values :: [(VCDID, E.EventList RepValue)] -> String+values sigs = dumpVars initials ++ eventList rest+ where (initials,rest) = unzip [ ((i, E.head el), (i, el)) | (i, el) <- sigs ]++dumpVars :: [(VCDID, RepValue)] -> String+dumpVars vals = "$dumpvars\n" ++ unlines (map (uncurry vcdVal) vals) ++ "$end\n"++eventList :: [(VCDID, E.EventList RepValue)] -> String+eventList strms = E.foldrWithTime (\(t,ls) r -> "#" ++ show t ++ "\n" ++ ls ++ "\n" ++ r) "" elist+ where elist = E.mergeWith (\s1 s2 -> s1 ++ ('\n':s2))+ [ fmap (vcdVal ident) elist' | (ident,elist') <- strms ]++vcdVal :: VCDID -> RepValue -> String+vcdVal i r@(RepValue bs) | length bs == 1 = rep2tbw r ++ i+ | otherwise = "b" ++ rep2tbw r ++ " " ++ i++----------------------------------------------------------------------------------------++-- | Compare two trace objects. First argument is the golden value. See notes for cmpRepValue+cmpVCD :: VCD -> VCD -> Bool+cmpVCD (VCD m1) (VCD m2) =+ and [ k1 == k2 && cmpVC (tslen s1) s1 s2+ | ((k1,s1),(k2,s2)) <- zip (sorted m1) (sorted m2)+ ]+ where tslen (VC _ el) = E.length el+ sorted = sortBy ((compare) `on` fst)++ioOnly :: VCD -> VCD+ioOnly = VCD . scopes ["inputs","outputs"]++-- | 'cmpVC' compares two traces to determine equivalence. Note this+-- uses 'cmpRepValue' under the hood, so the first argument is considered the+-- golden trace.+cmpVC :: Int -> VC -> VC -> Bool+cmpVC count (VC t1 s1) (VC t2 s2) = t1 == t2 && countLTs1 && s1LTs2 && eql+ where countLTs1 = count <= E.length s1+ s1LTs2 = E.length s1 <= E.length s2+ eql = F.foldr (&&) True $ E.zipWith cmpRepValue (E.take count s1) (E.take count s2)++-- | Make a 'VCD' from a 'Fabric' and its input.+mkVCD :: Int -- ^ number of cycles to capture+ -> Fabric () -- ^ The Fabric we are tracing+ -> [(String,Pad)] -- ^ Inputs to the Fabric+ -> IO VCD+mkVCD c fabric input = do+ (trace, _) <- mkVCDCM c fabric input (return)+ return trace++-- | Version of 'mkVCD' that accepts arbitrary circuit mods.+mkVCDCM :: Int -- ^ number of cycles to capture+ -> Fabric () -- ^ Fabric we are tracing+ -> [(String, Pad)] -- ^ Inputs to the Fabric+ -> (KLEG -> IO KLEG) -- ^ KLEG Mod+ -> IO (VCD, KLEG)+mkVCDCM c fabric input circuitMod = do+ rc <- (reifyFabric >=> circuitMod) fabric++ let (_,output) = runFabric fabric input+ tr = VCD $ [ ("inputs/" ++ nm, padToVC c p)+ | (nm,_) <- theSrcs rc+ , (nm',p) <- input+ , nm == nm' ]+ ++ [ ("outputs/" ++ nm, padToVC c p)+ | (nm,_,_) <- theSinks rc+ , (nm',p) <- output+ , nm == nm' ]++ return (tr, rc)++----------------------------------------------------------------------------------------++-- | Convert the inputs and outputs of a VCD to the textual format expected+-- by a testbench.+writeTBF :: String -> VCD -> IO ()+writeTBF filename = writeFile filename . unlines . mergeWith (++) . asciiStrings++-- | Inverse of showTBF, needs a signature for the shape of the desired VCD.+-- Creates a VCD from testbench signal files.+readTBF :: [String] -> Signature -> VCD+readTBF ilines sig = VCD $ ins ++ outs+ where et = fromSignature sig+ widths = [ typeWidth ty+ | (_,VC ty _) <- inputs et ++ outputs et+ ]+ (inSigs, outSigs) = splitAt (length $ inputs et) $ splitLists ilines widths+ addToMap sigs m = [ (k,VC ty $ E.fromList $ map tbw2rep strm)+ | (strm,(k,VC ty _)) <- zip sigs m+ ]+ (ins, outs) = (addToMap inSigs $ inputs et, addToMap outSigs $ outputs et)++-- | Convert a VCD into a list of lists of Strings, each String is a value,+-- each list of Strings is a signal.+asciiStrings :: VCD -> [[String]]+asciiStrings vcd = [ E.toList $ fmap rep2tbw s | VC _ s <- insOuts ]+ where insOuts = [ ts | (_,ts) <- inputs vcd ++ outputs vcd ]++-- | Convert string representation used in testbench files to a RepValue+-- Note the reverse here is crucial due to way vhdl indexes stuff+tbw2rep :: String -> RepValue+tbw2rep vals = RepValue [ case v of+ 'X' -> Nothing+ '1' -> Just True+ '0' -> Just False+ 'U' -> Nothing+ other -> error $ "tbw2rep: bad character! " ++ [other]+ | v <- reverse vals ]++-- | Convert a RepValue to the string representation used in testbench files+rep2tbw :: RepValue -> String+rep2tbw (RepValue vals) = [ case v of+ Nothing -> 'X'+ Just True -> '1'+ Just False -> '0'+ | v <- reverse vals ]+
+ Language/KansasLava/VCD/EventList.hs view
@@ -0,0 +1,154 @@+module Language.KansasLava.VCD.EventList+ ( EventList+ , toList+ , fromList+ , empty+ , singleton+ , length+ , head+ , last+ , take+ , drop+ , insert+ , snoc+ , append+ , zipWith+ , mergeWith+ , foldrWithTime+ ) where++import Control.Monad++import qualified Data.Foldable as F+import qualified Data.IntMap as M+import Data.Maybe++import Prelude hiding (take,length,zipWith,last,head,drop)+import qualified Prelude as Prelude++----------------------------------------------------------------------------------------++-- | A finite list of changes, indexed from 0.+newtype EventList a = EL { unEL :: M.IntMap a }+ deriving (Eq,Show,Read)++instance (Ord a) => Ord (EventList a) where+ compare exs eys = compare (toList exs) (toList eys)++instance Functor EventList where+ fmap f (EL evs) = EL $ M.map f evs++instance F.Foldable EventList where+ foldr f z (EL m) = M.fold f z m++{-+instance (Show a) => Show (EventList a) where+ show = show . toList++instance (Eq a, Read a) => Read (EventList a) where+ readsPrec p str = [ (fromList l,r) | (l,r) <- readsPrec p str ]+-}++-- | Convert an event list to a normal list+toList :: EventList a -> [a]+toList (EL evs) = fst $ foldr f ([],Nothing) $ M.toAscList evs+ where f :: (Int,a) -> ([a],Maybe Int) -> ([a],Maybe Int)+ f (i,v) (l,p) = (replicate ((fromMaybe (i+1) p) - i) v ++ l,Just i)++-- | Convert a list to an event list+fromList :: (Eq a) => [a] -> EventList a+fromList = EL . M.fromDistinctAscList . dedupe Nothing . zip [0..]+ where dedupe _ [] = []+ dedupe _ [(i,v)] = [(i,v)] -- always keep the last item for size+ dedupe Nothing ((i,v):r) = (i,v) : dedupe (Just v) r+ dedupe (Just p) ((i,v):r) | v == p = dedupe (Just v) r+ | otherwise = (i,v) : dedupe (Just v) r++empty :: EventList a+empty = EL M.empty++singleton :: (Int,a) -> EventList a+singleton = EL . uncurry M.singleton++-- | snoc for event lists.+snoc :: (Eq a) => EventList a -> a -> EventList a+snoc el v = insert (length el,v) el++-- | Insert/update an event in an EventList.+insert :: (Eq a) => (Int, a) -> EventList a -> EventList a+insert (i,v) (EL m) = EL $ maybe (if M.null b || last (EL b) /= v+ then M.insert i v m+ else m)+ (const m) p+ where (b,p,_) = M.splitLookup i m++-- | head for event lists. O(1)+head :: EventList a -> a+head (EL m) | M.null m = error "EventList.head: empty list"+ | otherwise = Prelude.head $ M.elems m+++-- | last for event lists. O(n)+last :: EventList a -> a+last (EL m) | M.null m = error "EventList.last: empty list"+ | otherwise = Prelude.last $ M.elems m++-- | length for event lists O(n)+length :: EventList a -> Int+length (EL m) = case reverse $ M.keys m of+ [] -> 0+ (k:_) -> k + 1++-- | take for event lists.+take :: Int -> EventList a -> EventList a+take i (EL m) | i < 0 = error "EventList.take negative index"+ | i > length (EL m) = EL m+ | otherwise = if length el' == i+ then el'+ else EL $ M.insert (i-1) (if M.null b then undefined else last el') b+ where (b,_) = M.split i m+ el' = EL b++-- | drop for event lists.+drop :: Int -> EventList a -> EventList a+drop i (EL m) = EL m'+ where (b,p',a) = M.splitLookup i m -- if p exists, add it, otherwise add last item in b if+ -- first item in a is not at zero+ p = maybe [] (\v -> [(0,v)]) p'+ m' = M.fromAscList $ case p ++ [ (i'-i,v) | (i',v) <- M.toAscList a ] of+ [] -> []+ l@((0,_):_) -> l+ l -> (0,if M.null b then undefined else last (EL b)) : l++append :: (Eq a) => EventList a -> EventList a -> EventList a+append el@(EL xs) (EL ys) = EL $ M.union xs ys'+ where l = length el+ ys' = M.fromAscList $ fix [ (i+l,v) | (i,v) <- M.toAscList ys ]++ fix [] = []+ fix bbs@(b:bs) | (not $ M.null xs) && (last el == snd b) = bs+ | otherwise = bbs++-- | zipWith for event lists.+-- zipWith f xs ys = fromList $ zipWith f (toList xs) (toList ys)+zipWith :: (Eq c) => (a -> b -> c) -> EventList a -> EventList b -> EventList c+zipWith f xs ys = EL $ M.fromList $ go (ea,eb) (lst xs) (lst ys)+ where lst = M.assocs . unEL . take l+ l = min (length xs) (length ys)+ ea = error "zipWith: no initial value in list a"+ eb = error "zipWith: no initial value in list b"++ go (pa,_) [] bs = [ (i,f pa b) | (i,b) <- bs ]+ go (_,pb) as [] = [ (i,f a pb) | (i,a) <- as ]+ go (pa,pb) ((i,a):as) ((i',b):bs) | i < i' = (i ,f a pb) : go (a,pb) as ((i',b):bs)+ | i == i' = (i ,f a b ) : go (a,b ) as bs+ | otherwise = (i',f pa b ) : go (pa,b) ((i,a):as) bs++-- | Like zipWith, but generalized to a list of event lists.+mergeWith :: (Eq a) => (a -> a -> a) -> [EventList a] -> EventList a+mergeWith _ [] = fromList []+mergeWith f ls = foldr1 (zipWith f) ls++-- | Like foldr, but gives the clock value to the function.+foldrWithTime :: ((Int,a) -> b -> b) -> b -> EventList a -> b+foldrWithTime f z (EL m) = M.foldWithKey (curry f) z m
+ Language/KansasLava/VHDL.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ParallelListComp #-}++-- | This module converts a Lava circuit to a synthesizable VHDL netlist.+module Language.KansasLava.VHDL(writeVhdlCircuit, writeVhdlPrelude, mkTestbench) where++import Data.List(mapAccumL)++import Language.KansasLava.Netlist.Utils(toStdLogicExpr,toStdLogicTy, isMatrixStdLogicTy, sizedRange)+import Language.KansasLava.Netlist.Decl+import Language.KansasLava.Netlist.Inst+import Language.KansasLava.Types++import Language.Netlist.AST+import Language.Netlist.GenVHDL++import qualified Data.Map as M+import System.Directory+import System.FilePath.Posix+import Data.Char+import Data.Reify(Unique)++import Paths_kansas_lava++-- | The 'vhdlCircuit' function converts a Lava KLEG into a VHDL entity/architecture pair.+writeVhdlCircuit :: String -> FilePath -> KLEG -> IO ()+writeVhdlCircuit nm file cir = do+ nlMod <- netlistCircuit nm cir+ writeFile file (genVHDL nlMod mods)+ where+ -- we always use the following 'use' statements.+ mods = ["work.lava.all","work.all"]++-- | Write the Lava Prelude into this file.+-- For example:+--+-- > writeVhdlPrelude "Lava.vhd" +--+writeVhdlPrelude :: FilePath -> IO ()+writeVhdlPrelude prel_dest = do+ prel_src <- getDataFileName "Prelude/VHDL/Lava.vhd"+ copyFile prel_src prel_dest++mkTestbench :: String -> FilePath -> KLEG -> IO ()+mkTestbench name path circuit = do+ createDirectoryIfMissing True path++ writeFile (path </> name ++ "_tb.vhd")+ $ entity name ++ architecture name (preprocessNetlistCircuit circuit)++ writeFile (path </> name <.> "do") $ doscript name++entity :: String -> String+entity name = unlines+ ["library ieee;",+ "use ieee.std_logic_1164.all;",+ "use ieee.std_logic_textio.all;",+ "library std;",+ "use std.textio.all;",+ "library work;",+ "entity " ++ name ++ "_tb is",+ "begin",+ "end entity " ++ name ++ "_tb;"+ ]++architecture :: String -> KLEG -> String+architecture name circuit = unlines $+ ["architecture sim of " ++ name ++ "_tb is"+ ,"signal clk : std_logic := '1';"+ ,"signal rst : std_logic := '0';"+ ,"constant input_size : integer := 16;"+ ,"constant output_size : integer := 16;"+ ,"signal input : " ++ portType (ins ++ outs) ++ ":= (others => '0');"+ ,"signal output : " ++ portType (ins ++ outs) ++ ";"+ ,"begin"+ ,stimulus name ins outs+ ,dut name ins outs sequentials+ ,"end architecture sim;"]+ where (ins, outs, sequentials) = ports circuit++dut :: String -> [(String, Type)] -> [(String, Type)] -> [(String, Type)] -> String+dut name ins outs sequentials = unlines $ [+ "dut: entity work." ++ name,+ "port map ("] +++ ["\t" ++ c ++ " => " ++ case c of+ "clk_en" -> "'1',"+ "clk" -> "clk,"+ "rst" -> "rst,"+ n -> n+ | (c,_) <- sequentials] +++ (let xs = portAssigns ins outs in (init xs) ++ [init (last xs)]) +++ [");"]++-- TODO: add clock speed argument+stimulus :: String -> [(a, Type)] -> [(a, Type)] -> String+stimulus name ins outs = unlines $ [+ "runtest: process is",+ "\tFILE " ++ inputfile ++ " : TEXT open read_mode IS \"" ++ name ++ ".in.tbf\";",+ "\tFILE " ++ outputfile ++ " : TEXT open write_mode IS \"" ++ name ++ ".out.tbf\";",+ "\tVARIABLE line_in,line_out : LINE;",+ "\tvariable input_var : " ++ portType (ins ++ outs) ++ ";",+ "\tvariable output_var : " ++ portType (ins ++ outs) ++ ";",+ "\tvariable needs_rst : boolean := false;",++ "begin",++ "\twhile not endfile (" ++ inputfile ++ ") loop",+ "\t\tREADLINE(" ++ inputfile ++ ", line_in);",+ "\t\tREAD(line_in,input_var);",+ -- clock start+ "\t\tclk <= '1';",+ pause 1,+ "\t\tinput <= input_var;",+ "\t\tif needs_rst then",+ "\t\t\trst <= '1';",+ "\t\tend if;",+ "\t\toutput(" ++ outputRange ++ ") <= input_var(" ++ outputRange ++ ");",+ pause 4,+ "\t\tclk <= '0';",+ pause 4,+ "\t\tif needs_rst then",+ "\t\t\trst <= '0';",+ "\t\t\tneeds_rst := false;",+ "\t\tend if;",+ "\t\toutput_var := output;",+ "\t\tWRITE(line_out, output_var);",+ "\t\tWRITELINE(" ++ outputfile ++ ", line_out);",+ pause 1,+ "\tend loop;",+ "\twait;",+ "end process;"+ ]+ where inputfile = name ++ "_input"+ outputfile = name ++ "_output"+ clockSpeed = 50 -- ns+ pause n = "\t\twait for " ++ (show (n * clockSpeed `div` (10 ::Int))) ++ " ns;"+ outputRange = show (portLen (ins ++ outs) - 1) ++ " downto " ++ show (portLen outs)++-- Manipulating ports+ports :: KLEG -> ([(String, Type)],[(String, Type)],[(String, Type)])+ports reified = (ins, outs, clocks)+ where ins = [(nm,ty) | (nm,ty) <- theSrcs reified, nm `notElem` ["clk","rst","clk_en"]]+ outs = [(nm,ty) | (nm,ty,_) <- theSinks reified]+ clocks = [(nm,ty) | (nm,ty) <- theSrcs reified, nm `elem` ["clk","rst","clk_en"]]+-- resets = [(nm,RstTy) | (nm,RstTy) <- theSrcs reified]++portType :: [(a, Type)] -> [Char]+portType pts = "std_logic_vector(" ++ show (portLen pts - 1) ++ " downto 0)"++portLen :: [(a, Type)] -> Int+portLen pts = sum (map (typeWidth .snd) pts)++portAssigns :: [(String, Type)]-> [(String, Type)] -> [String]+portAssigns ins outs = imap ++ omap+ where assign sig idx (B,n,1) =+ (idx + 1, "\t" ++ n ++ " => " ++ sig ++ "(" ++ show idx ++ "),")+ assign sig idx (_,n,k) =+ (idx + k, "\t" ++ n ++ " => " ++ sig ++ "(" ++ show (idx + k - 1) ++" downto " ++ show idx ++ "),")+ (_,imap) = mapAccumL (assign "input") (portLen outs) $ reverse [(ty,n,typeWidth ty) | (n,ty) <- ins]+ (_,omap) = mapAccumL (assign "output") 0 $ reverse [(ty,n,typeWidth ty) | (n,ty) <- outs]++-- Modelsim 'do' script+doscript :: String -> String+doscript name = unlines $+ ["vlib " ++ workDir+ ,"vcom -work mywork Lava.vhd"+ ,"if [catch {vcom -work " ++ workDir ++ " " ++ name ++ ".vhd} einfo] {"+ ," puts $einfo"+ ," } else {"+ ," vcom -work " ++ workDir ++ " " ++ name ++ "_tb.vhd"+ ," vsim -lib " ++ workDir ++ " " ++ name ++ "_tb"+ ," add wave -r /*"+ ," run -all"+ ," }"+ ,"quit"+ ]+ where workDir = "mywork"+-- waves = genProbes name circuit+++----------------------------------------------------------------------------------++-- | The 'netlistCircuit' function converts a Lava circuit into a Netlist AST+-- The circuit type must implement the 'Ports' class. If the circuit type is+-- a function, the function arguments will be exposed as input ports, and the+-- result will be exposed as an output port (or ports, if it is a compound+-- type).+netlistCircuit :: String -- ^ The name of the generated entity.+ -> KLEG -- ^ The Lava circuit.+ -> IO Module+netlistCircuit name circ = do+ let (KLEG nodes srcs sinks) = preprocessNetlistCircuit circ++ let inports = checkPortType srcs+ let outports = checkPortType (map outputNameAndType sinks)++ -- Finals are the assignments from the output signals for entities to the output ports+ let finals = [ NetAssign n (toStdLogicExpr ty x) | (n,ty,x) <- sinks+ , case toStdLogicTy ty of+ MatrixTy {} -> error "can not have a matrix as an out argument"+ _ -> True+ ]++ return $ Module name inports outports []+ (concatMap genDecl nodes +++ concatMap (uncurry (genInst' (M.fromList nodes))) nodes +++ finals)+++ where checkPortType ports' = [ (nm,sizedRange ty) | (nm, ty) <- ports'+ , not (isMatrixStdLogicTy ty) || error "can not have a matrix as a port"+ ]+ outputNameAndType (n,ty,_) = (n,ty)++++-- | This gets a circuit ready for Netlist generation.+-- Specifically, it normalizes all the arguments+-- because arguments that are of type MatrixTy are now supported.+-- 'netlistCircuit' calls 'preprocessNetlistCircuit' before generating 'Module'.+preprocessNetlistCircuit :: KLEG -> KLEG+preprocessNetlistCircuit cir = res+ where+ KLEG nodes srcs sinks = cir+ res = KLEG nodes' srcs' sinks'++ vars = allocEntities cir++ (sinkVars,srcVars) = splitAt (length sinks) vars++ nodes' = map fixUp nodes ++ nodesIn ++ nodesOut++ -- figure out the list of srcs+ srcs' = [ (nm ++ extra1, ty2)+ | (nm, ty) <- srcs+ , (extra1,ty2)+ <- case toStdLogicTy ty of+ B -> [("",ty)]+ V _ -> [("",ty)]+ MatrixTy n (V _)+ -> let (MatrixTy _ inner) = ty+ in reverse [("_x" ++ show j,inner) | j <- [0..(n-1)]]+ other -> error $ show ("srcs",other)+-- | k <- [0..] -- This gives them better sorting numbers+ ]+++ extras0 :: [(String,Entity Unique)]+ extras0 = [ (nm, Entity (Prim "concat")+ [("o0",ty)]+ [ ( 'i':show j+ , case ty of+ MatrixTy _ inner -> inner+ _ -> error $ "preprocessVhdlCircuit: not a matrix type " ++ show ty+ , case [ nm'+ | (nm',_) <- srcs'+ , nm' == (nm ++ "_x" ++ show j)+ ] of+ [] -> error ("could not find " ++ show nm)+ [x] -> Pad x+ _ -> error ("too many of " ++ show nm)+ )+ | j <- [0..(getMatrixNumColumns ty - 1)]]+ )+ | (nm, ty) <- srcs+ , isMatrixStdLogicTy ty+ ]++ getMatrixNumColumns (MatrixTy c _) = c+ getMatrixNumColumns _ = error "Can't get number of columns for non-matrix type"++ extras1 :: [(Unique, (String, Entity Unique))]+ extras1 = zip srcVars extras0++ nodesIn :: [(Unique, Entity Unique)]+ nodesIn = [ (u,e) | (u,(_,e)) <- extras1 ]++ --------------------------------------------------------------------------------------------++ sinks' = [ (nm ++ extra1, ty2, dr2)+ | (u,(nm, ty, dr)) <- zip sinkVars (sinks)+ , (extra1,ty2,dr2)+ <- case toStdLogicTy ty of+ B -> [("",ty,dr)]+ V _ -> [("",ty,dr)]+ MatrixTy n (V _)+ -> let (MatrixTy _ inner) = ty+ in reverse [ ("_x" ++ show j,inner,Port ('o':show j) u) | j <- [0..(n-1)]]+ other -> error $ show ("sinks",other)+-- | k <- [0..] -- This gives them better sorting numbers+ ]+++ nodesOut :: [(Unique, Entity Unique)]+ nodesOut = [ (u,Entity (Prim "unconcat")+ [('o':show j,innerTy) | j <- [0..(n-1)]]+ [("i0",ty,dr)])+ | (u,(_, ty, dr)) <- zip sinkVars (sinks)+ , (innerTy,n )+ <- case toStdLogicTy ty of+ B -> []+ V _ -> []+ MatrixTy n (V _)+ -> let (MatrixTy _ inner) = ty+ in [ (inner,n) ]+ other -> error $ show ("nodesOut",other)+ ]++ --------------------------------------------------------------------------------------------++ fixUp :: (Unique,Entity Unique) -> (Unique, Entity Unique)+ fixUp (i,Entity e ins outs) = (i,+ Entity e ins+ [ (o,t,case d of+ Pad nm+ -> case [ u | (u,(o3,_)) <- extras1, nm == o3 ] of+ [u] -> Port "o0" u+ [] -> case [ nm' | (nm',_) <- srcs', nm == dropWhile isDigit nm' ] of+ [nm'] -> Pad nm'+ _ -> error "fixUp find"+ _ -> error "fixUp"+ other -> other+ ) | (o,t,d) <- outs ])
@@ -0,0 +1,2 @@+ </body>+</html>
+ Prelude/HTML/header.inc view
@@ -0,0 +1,63 @@+<html>+ <head>+ <title>Kansas Lava Unit Tests</title>+ <style>+ <!--+ div { margin: 0em 2em 0.1em 1em;+ }+ #summary { margin-bottom: 2em; }+ #summary td { text-align: right; padding-right: 1em; }+ .huge { margin: 0em; font-size: 4em; }+ .kindahuge { margin: 0em; font-size: 2em; }+ .allpass { color: #99FF66; }+ .somepass { color: #FF8040; }+ .allfail { color: red; }+ .additional { display: none; }+ .additional > div { white-space: pre-line; }+ .status { float: right; }++ .shallowfail { background-color: #FF3366; }+ .shallowpass { background-color: #99FF66; }+ .simgenerated { background-color: #99FF66; }+ .codegenfail { background-color: #FFFF99; }+ .compilefail { background-color: #FFFF99; }+ .simfail { background-color: #FFFF99; }+ .comparefail { background-color: #FF3366; }+ .pass { background-color: #99FF66; }+ -->+ </style>+ <script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.4.4/jquery.min.js"></script>+ <script type="text/javascript">+ $(document).ready(function() {+ $("div.header").click(function() {+ $(this).next(".additional").toggle();+ });+ $("#cgf").click(function() {+ $(".header").hide();+ $(".additional").hide();+ $(".codegenfail").show();+ });+ $("#vcf").click(function() {+ $(".header").hide();+ $(".additional").hide();+ $(".compilefail").show();+ });+ $("#cpf").click(function() {+ $(".header").hide();+ $(".additional").hide();+ $(".comparefail").show();+ });+ $("#osf").click(function() {+ $(".header").hide();+ $(".additional").hide();+ $(".simfail").show();+ });+ $("#showall").click(function() {+ $(".additional").hide();+ $(".header").show();+ });+ });+ </script>+ </head>+ <body>+ <div id="summary">
+ Prelude/HTML/mid.inc view
@@ -0,0 +1,2 @@+ </div>+
+ Prelude/VHDL/Lava.vhd view
@@ -0,0 +1,418 @@+-- These are core Lava built-in functions Lava programs can rely on having+-- Todo: Consider prepending lava_ to the names.++-- These are core Lava built-in functions Lava programs can rely on having +-- Todo: Consider prepending lava_ to the names. ++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.NUMERIC_STD.ALL;++package lava is+ function lava_to_std_logic (i0 : std_logic_vector(0 downto 0)) return std_logic;+end;++package body lava is+ -- This is because we store memories of booleans as vector(0 downto 0)+ function lava_to_std_logic (i0 : std_logic_vector(0 downto 0)) return std_logic is+ begin+ return i0(0);+ end;+end lava;++--------------------------------------------------------------------------------+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.STD_LOGIC_SIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_register is+ generic(+ width : natural;+ def : integer+ );+ port(+ rst : in std_logic;+ clk : in std_logic;+ clk_en : in std_logic;+ i0 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0)+ );+end entity lava_register;++architecture Behavioral of lava_register is+ signal reg : std_logic_vector(width-1 downto 0) := STD_LOGIC_VECTOR(TO_SIGNED(def,width));+begin+ proc : process(rst, clk, clk_en) is+ begin+ if rst = '1' then+ reg <= STD_LOGIC_VECTOR(TO_SIGNED(def,width));+ elsif rising_edge(clk) then+ if (clk_en = '1') then+ reg <= i0;+ end if;+ end if;+ end process proc;+ o0 <= reg;+end Behavioral;+--------------------------------------------------------------------------------+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.STD_LOGIC_SIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_delay is+ generic(+ width : natural+ );+ port(+ rst : in std_logic;+ clk : in std_logic;+ clk_en : in std_logic;+ i0 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0)+ );+end entity lava_delay;++architecture Behavioral of lava_delay is+begin+ proc : process(rst, clk, clk_en) is+ begin+ if rising_edge(clk) then+ if (clk_en = '1') then+ o0 <= i0;+ end if;+ end if;+ end process proc;+end Behavioral;++++--------------------------------------------------------------------------------+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_bram is+ generic(+ addr_width : natural;+ data_width : natural;+ element_count : natural;+ sync : natural+ );+ port (+ rst : in std_logic;+ clk : in std_logic;+ clk_en : in std_logic;+ wEn : in std_logic;+ wAddr : in std_logic_vector(addr_width-1 downto 0);+ wData : in std_logic_vector(data_width-1 downto 0);+ rAddr : in std_logic_vector(addr_width-1 downto 0);+ o0 : out std_logic_vector(data_width-1 downto 0)+ );+end entity lava_bram;++architecture Behavioral of lava_bram is+ type mem_type is array (element_count-1 downto 0) of std_logic_vector(data_width-1 downto 0);+ signal mem : mem_type := (others => (others => 'X'));+begin+ proc : process(rst, clk, clk_en) is+ begin+ if rising_edge(clk) then+ if (clk_en = '1') then+ if (wEn = '1') then+ mem(to_integer(unsigned(wAddr))) <= wData;+ end if;+ end if;+ end if;+ if sync = 0 then+ -- async; someone else adding any delays on writing.+ o0 <= mem(to_integer(unsigned(rAddr))); + else+ if rising_edge(clk) then+ if (clk_en = '1') then+ -- sync; with built in delay+ o0 <= mem(to_integer(unsigned(rAddr)));+ end if;+ end if;+ end if; + end process proc;+ +end Behavioral;+++--------------------------------------------------------------------------------+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_unsigned_mul is+ generic(+ width : natural+ );+ port (+ i0 : in std_logic_vector(width-1 downto 0);+ i1 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0)+ );+end entity lava_unsigned_mul;+++architecture Behavioral of lava_unsigned_mul is+ signal tmp : std_logic_vector(2*width-1 downto 0);+begin+ -- a version of multiply that has the same sized output+ tmp <= std_logic_vector((unsigned(i0)) * (unsigned(i1)));+ o0 <= tmp(width-1 downto 0);+end Behavioral;++--------------------------------------------------------------------------------+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_signed_mul is+ generic(+ width : natural+ );+ port (+ i0 : in std_logic_vector(width-1 downto 0);+ i1 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0)+ );+end entity lava_signed_mul;+++architecture Behavioral of lava_signed_mul is+ signal tmp : std_logic_vector(2*width-1 downto 0);+begin+ -- a version of multiply that has the same sized output+ tmp <= std_logic_vector((signed(i0)) * (signed(i1)));+ o0 <= tmp(width-1 downto 0);+end Behavioral;+++--------------------------------------------------------------------------------+-- TO fix below this+library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_sampled_add is+ generic (+ width : natural := 8; -- signal width+ frac_width : natural := 8); -- value for max * min + port(i0 : in std_logic_vector(width-1 downto 0);+ i1 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0));+end entity lava_sampled_add;++architecture Behavioral of lava_sampled_add is+ signal tmp : signed(width-1 + 1 downto 0);+ signal top2Bits : std_logic_vector(1 downto 0);+ constant zeros : std_logic_vector(width - 2 downto 0) := (others => '0');+ constant ones : std_logic_vector(width - 2 downto 0) := (others => '1');+begin+ tmp <= signed (i0(width-1) & i0) + signed (i1(width-1) & i1);+ top2Bits <= std_logic_vector(tmp(width downto width-1));+ o0 <= '0' & ones when top2Bits = "01" else+ '1' & zeros when top2Bits = "10" else+ std_logic_vector(tmp(width-1 downto 0));++end Behavioral;++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;+++entity lava_sampled_sub is+ generic (+ width : natural := 8; -- signal width+ frac_width : natural := 8); -- value for max * min + port(i0 : in std_logic_vector(width-1 downto 0);+ i1 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0));+end entity lava_sampled_sub;++architecture Behavioral of lava_sampled_sub is+ signal tmp : signed(width-1 + 1 downto 0);+ constant zeros : std_logic_vector(width - 2 downto 0) := (others => '0');+ constant ones : std_logic_vector(width - 2 downto 0) := (others => '1');+begin+ tmp <= signed (i0(width-1) & i0) - signed (i1(width-1) & i1);+ o0 <= '0' & ones when tmp(width downto width-1) = "01" else+ '1' & zeros when tmp(width downto width-1) = "10" else+ std_logic_vector(tmp(width-1 downto 0));+end Behavioral;+++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity lava_sampled_mul is+ generic (+ width : natural := 8; -- signal width+ frac_width : natural := 4); -- value for max * min + port(i0 : in std_logic_vector(width-1 downto 0);+ i1 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0));+end entity lava_sampled_mul;++architecture Behavioral of lava_sampled_mul is+ signal tmp : signed(2*width-1 downto 0);+ signal topBits : signed(width-1 downto 0);+ signal r0 : signed(2*width-1 downto frac_width);+ signal r1 : signed(2*width-1 downto frac_width);+ constant zeros : std_logic_vector(width - 2 downto 0) := (others => '0');+ constant ones : std_logic_vector(width - 2 downto 0) := (others => '1');+begin+ tmp <= signed (i0) * signed (i1);+ r0 <= tmp(2*width-1 downto frac_width);+ -- This is Round half to even (http://en.wikipedia.org/wiki/Rounding#Round_half_to_even)+ r1 <= r0 when tmp(frac_width-1) = '0' else+ r0 when tmp(frac_width) = '0' and tmp(frac_width-1) = '1' and tmp (frac_width - 2 downto 0) = 0 else + r0 + 1;+ o0 <= std_logic_vector(r1(frac_width + width - 1 downto frac_width))+ when r1(2*width-1 downto frac_width + width-1) = 0 else+ std_logic_vector(r1(frac_width + width - 1 downto frac_width))+ when r1(2*width-1 downto frac_width + width-1) = -1 else+ '1' & zeros when tmp(2*width-1) = '1' else '0' & ones;+end Behavioral;++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;+++entity lava_sampled_negate is+ generic (+ width : natural := 8; -- signal width+ frac_width : natural := 8); -- value for max * min + port(i0 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0));+end entity lava_sampled_negate;++architecture Behavioral of lava_sampled_negate is+ signal tmp : signed(width-1 + 1 downto 0);+ constant zeros : std_logic_vector(width - 2 downto 0) := (others => '0');+ constant ones : std_logic_vector(width - 2 downto 0) := (others => '1');+begin+ tmp <= - signed (i0(width-1) & i0);+ o0 <= '0' & ones when tmp(width downto width-1) = "01" else+ '1' & zeros when tmp(width downto width-1) = "10" else+ std_logic_vector(tmp(width-1 downto 0));+end Behavioral;++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity sampled_fixedDivPowOfTwo is+ generic (+ width : natural := 8; -- signal width+ frac_width : natural := 8; -- value for max * min+ shift_by : natural);+ port(i0 : in std_logic_vector(width-1 downto 0);+ o0 : out std_logic_vector(width-1 downto 0));+end entity sampled_fixedDivPowOfTwo;++architecture Behavioral of sampled_fixedDivPowOfTwo is+ signal r0 : std_logic_vector(width-1 downto 0);+begin+ -- sign extend+ r0 <= (width-1 downto width-(shift_by +1) => i0(width-1)) & i0(width-2 downto shift_by);++ -- This is Round half to even (http://en.wikipedia.org/wiki/Rounding#Round_half_to_even)+ o0 <= r0 when i0(shift_by-1) = '0' else+ r0 when i0(shift_by) = '0' and i0(shift_by-1) = '1' and (shift_by = 1 or i0(shift_by - 2 downto 0) = 0) else+ r0 + 1;++end Behavioral;++-------------------------------------------------------------------------------+-- Flux stuff+-------------------------------------------------------------------------------++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity upflux is+ port(i0 : in std_logic_vector;+ go : in std_logic;+ clk_en : in std_logic;+ clk : in std_logic;+ rst : in std_logic;+ o_en : out std_logic;+ o0 : out std_logic_vector;+ o_clk_en : out std_logic);+end entity upflux;++architecture Behavioral of upflux is+ signal reg : std_logic := '0';+begin+ o_en <= reg;+ o0 <= i0; -- Flowthrough+ o_clk_en <= go and clk_en; -- go, based on your clock enable+ + proc : process(rst, clk, clk_en) is+ begin+ if rising_edge(clk) then+ if (clk_en = '1') then+ reg <= go;+ end if;+ end if;+ end process proc;++end Behavioral;+++library IEEE;+use IEEE.STD_LOGIC_1164.ALL;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;++entity downflux is+ generic(+ width : natural+ );+ port (i0 : in std_logic_vector(width-1 downto 0);+ en : in std_logic;+ clk : in std_logic;+ rst : in std_logic;+ clk_en : in std_logic;+ go : out std_logic;+ o0 : out std_logic_vector(width-1 downto 0)); +end entity downflux;++architecture Behavioral of downflux is+ signal reg : std_logic_vector(width-1 downto 0);+begin+ go <= en; -- this signal becomes the clock enable.+ o0 <= reg; -- this is a lava delay++ proc : process(rst, clk, clk_en) is+ begin+ if rising_edge(clk) then+ if (clk_en = '1') then+ reg <= i0; + end if;+ end if;+ end process proc;+ + +end Behavioral;+
+ Prelude/VHDL/Modelsim.vhd view
@@ -0,0 +1,189 @@+library ieee;+use ieee.std_logic_1164.all;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;+use ieee.std_logic_textio.all;+library std;+use std.textio.all;+library work;++entity tb_env is+ generic (+ clk_period : time := 10 ns; -- 100MHz+ cycle_count : integer := 1000+); + port (+ clk : out std_logic;+ clk_en : out std_logic;+ rst : out std_logic+);+end entity;++-- This is the vhdl/modelsim version of shallowEnv.+architecture Behavioral of tb_env is+begin+ runenv: process is+ variable counter : integer := cycle_count;+ begin+ clk <= '0';+ clk_en <= '1';+ rst <= '0';+ wait for clk_period / 2;+-- Use these three if you *need* reset.+-- rst <= '1';+-- wait for clk_period / 2;+-- rst <= '0';+ while counter > 0 loop+ if (counter mod 100 = 0) then+ report("cycle: " & integer'image(cycle_count - counter));+ end if;+ counter := counter - 1;+ wait for clk_period / 2;+ clk <= '1'; -- rising edge+ wait for clk_period / 2;+ clk <= '0'; -- falling edge+ end loop;+ report "End of simulation." severity note;+ wait;+ end process;+end architecture;++library ieee;+use ieee.std_logic_1164.all;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;+use ieee.std_logic_textio.all;+library std;+use std.textio.all;+library work;++-- A 'src' generator is a Master or Writer, the consumer is a Slave or Reader.+entity lava_src_pipe is+ generic (+ src_file_name : string+ ); + port (+ M_VALID : out std_logic;+ M_DATA : out std_logic_vector(7 downto 0);+ M_READY : in std_logic;++ clk : in std_logic;+ clk_en : in std_logic := '1';+ rst : in std_logic := '0'+ );+end entity;+++architecture Behavioral of lava_src_pipe is+begin+ runtest: process is+ type char_file is file of character;+ file my_file : char_file;+ variable my_char_v : character; + variable my_byte : std_logic_vector(7 downto 0);+ variable buf_empty : boolean := true; -- 1 element FIFO++ function str(b: boolean) return string is+ begin+ if b then+ return "true";+ else+ return "false";+ end if;+ end str;++ begin+ M_DATA <= (others => 'X');+ M_VALID <= '0';+ buf_empty := true;+ file_open(my_file, src_file_name, read_mode); + report("FILE: " & str(endfile(my_file)));++-- while (not endfile (my_file)) or (not buf_empty) loop+ while true loop+ -- Considerations are made on the rising edge+ wait until rising_edge(clk);++ -- if the previous packet was accepted, then empty the buffer token+ if M_READY = '1' then+ buf_empty := true;+ end if;++ -- if the buffer is empty, then fill it+ if buf_empty and not endfile(my_file) then+ report("READING");+ read(my_file, my_char_v); + report("READ: " & my_char_v);+ my_byte := std_logic_vector(to_unsigned(character'pos(my_char_v),8));+ buf_empty := false;+ end if;++ if buf_empty then+ M_DATA <= (others => 'X');+ M_VALID <= '0';+ else+ -- The buffer is now full, so send it+ M_DATA <= my_byte;+ M_VALID <= '1';+ end if;+ end loop;+-- wait until rising_edge(clk); +-- -- The buffer is now empty+-- M_DATA <= (others => 'X');+-- M_VALID <= '0';+ wait;+ end process;+end architecture;+library ieee;+use ieee.std_logic_1164.all;+use IEEE.STD_LOGIC_UNSIGNED.ALL;+use IEEE.NUMERIC_STD.ALL;+use ieee.std_logic_textio.all;+library std;+use std.textio.all;+library work;+++entity lava_sink_pipe is+ generic (+ sink_file_name : string+ ); + port (+ S_VALID : in std_logic;+ S_DATA : in std_logic_vector(7 downto 0);+ S_READY : out std_logic;++ clk : in std_logic;+ clk_en : in std_logic := '1';+ rst : in std_logic := '0'+ );+end entity;+++architecture Behavioral of lava_sink_pipe is+begin+ runtest: process is+ type char_file is file of character;+ file my_file : char_file;+ variable my_char_v : character; + variable my_byte : std_logic_vector(7 downto 0);+ variable buf_empty : boolean := true; -- 1 element FIFO+ begin+ S_READY <= '1'; -- Always ready+ while true loop+ -- Considerations are made on the rising edge+ wait until rising_edge(clk);++ -- if there is a value, then write it+ -- Very hacky, because ModelSim does not block if writing to a full pipe,+ -- we so need to open and close each time.+ if S_VALID = '1' then+ file_open(my_file, sink_file_name, append_mode); + my_char_v := character'val(to_integer(unsigned(S_DATA))); + write(my_file, my_char_v);+ file_close(my_file);+ report("WROTE: " & my_char_v);+ end if;+ end loop;+ end process;+end architecture;
+ README view
@@ -0,0 +1,16 @@+Kansas Lava++Kansas Lava is a Haskell library which allows the specification and+simulation of hardware, and hardware level concerns. Haskell+functions written in Kansas Lava can be interpreted as having the+semantics of a specific circuit, or compiled into VHDL, for+compilation and synthesis using standard HDL tools.++To run tests++% cabal configure -fall+% cabal build+% cd tests+% make test -- use 'make test ARGS=--gensim' if you want to generate VHDL+% make simulate -- [optional] if you want to test the VHDL using modelsim+% make report -- generate test report
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ kansas-lava.cabal view
@@ -0,0 +1,191 @@+Name: kansas-lava+Version: 0.2.4+Synopsis: Kansas Lava is a hardware simulator and VHDL generator.++Description: + Kansas Lava is a Domain Specific Language (DSL) for expressing+ hardware-oriented descriptions of computations, and is hosted inside+ the language Haskell. Kansas Lava programs are descriptions of+ specific hardware entities, the connections between them, and other+ computational abstractions that can compile down to these entities.++Category: Language, Hardware+License: BSD3+License-file: LICENSE+Author: Andy Gill+Maintainer: Andy Gill <andygill@ku.edu>+Copyright: (c) 2009-2011 The University of Kansas+Homepage: http://ittc.ku.edu/csdl/fpg/Tools/KansasLava+Stability: alpha+build-type: Simple+Cabal-Version: >= 1.10+Data-files: + Prelude/VHDL/*.vhd, + Prelude/HTML/*.inc+extra-source-files: + tests/Makefile+ README++Flag all+ Description: Enable full development tree+ Default: False++Flag unit+ Description: Enable unit testing binary+ Default: False++Flag tools+ Description: Enable extra tool binary+ Default: False++Library+ Build-Depends: + base >= 4 && < 5, + dotgen >= 0.4.1,+ containers,+ sized-types >= 0.3.4,+ data-default,+ random,+ strict,+ filepath,+ directory,+ cmdargs==0.8,+ process,+ netlist >= 0.3.1,+ netlist-to-vhdl >= 0.3.1,+ template-haskell, + bytestring,+ data-reify == 0.6+ Exposed-modules:+ Language.KansasLava+ Language.KansasLava.DOT+ Language.KansasLava.Entity+ Language.KansasLava.Fabric+ Language.KansasLava.Optimization+ Language.KansasLava.Probes+ Language.KansasLava.Protocols+ Language.KansasLava.Rep+ Language.KansasLava.RTL+ Language.KansasLava.Signal+ Language.KansasLava.Test+ Language.KansasLava.Types+ Language.KansasLava.Utils+ Language.KansasLava.VHDL+ Language.KansasLava.Stream+ Language.KansasLava.Dynamic+ Language.KansasLava.VCD+ Other-modules:+ Language.KansasLava.Internal+ Language.KansasLava.Rep.TH+ Language.KansasLava.Rep.Class+ Language.KansasLava.Netlist.Decl+ Language.KansasLava.Netlist.Inst+ Language.KansasLava.Netlist.Utils+ Language.KansasLava.Protocols.Enabled+ Language.KansasLava.Protocols.Memory+ Language.KansasLava.Protocols.AckBox+ Language.KansasLava.Protocols.ReadyBox+ Language.KansasLava.Protocols.Types+ Language.KansasLava.Protocols.Patch+ Language.KansasLava.VCD.EventList+ Paths_kansas_lava++-- need a module refactor to address the orphan warnings+ Ghc-Options: -Wall -fno-warn-orphans+ default-language: Haskell2010++-- Ghc-Prof-options: -auto-all++Executable kansas-lava-unittest+ if flag(unit) || flag(all)+ buildable: True+ Build-Depends:+ base >= 4 && < 5,+ dotgen >= 0.4.1,+ containers,+ sized-types >= 0.3.4,+ data-default,+ random,+ strict,+ filepath,+ directory,+ cmdargs==0.8,+ process,+ netlist >= 0.3.1,+ netlist-to-vhdl >= 0.3.1,+ template-haskell, + bytestring,+ data-reify == 0.6+ Other-modules:+ Coerce Matrix Memory Others Protocols Regression+ else+ Build-depends: base+ buildable: False+ Main-Is: Main.hs+ Hs-Source-Dirs: ., tests+ Ghc-Options: -Wall + -fno-warn-orphans -fcontext-stack=256+ -threaded -rtsopts+ default-language: Haskell2010++Executable kansas-lava-testreport+ if flag(unit) || flag(all)+ buildable: True+ Build-Depends:+ base >= 4 && < 5,+ dotgen >= 0.4.1,+ containers,+ sized-types >= 0.3.4,+ data-default,+ random,+ strict,+ filepath,+ directory,+ cmdargs==0.8,+ process,+ netlist >= 0.3.1,+ netlist-to-vhdl >= 0.3.1,+ template-haskell, + bytestring,+ data-reify == 0.6+ Other-modules:+ else+ Build-depends: base+ buildable: False+ Main-Is: GenReport.hs+ Hs-Source-Dirs: ., tests+ Ghc-Options: -Wall -fno-warn-incomplete-patterns+ -fno-warn-orphans -fcontext-stack=256+ default-language: Haskell2010++Executable kansas-lava-tbf2vcd+ if flag(tools) || flag(all)+ Build-Depends:+ base >= 4 && < 5,+ dotgen >= 0.4.1,+ containers,+ sized-types >= 0.3.4,+ data-default,+ random,+ strict,+ filepath,+ directory,+ cmdargs==0.8,+ process,+ netlist >= 0.3.1,+ netlist-to-vhdl >= 0.3.1,+ template-haskell, + bytestring,+ data-reify == 0.6+ buildable: True+ else+ Build-depends: base+ buildable: False+ Main-Is: TBF2VCD.hs+ Hs-Source-Dirs: ., tools+ Ghc-Options: -Wall -fno-warn-orphans+ default-language: Haskell2010++source-repository head+ type: git+ location: git://github.com/ku-fpg/kansas-lava.git
+ tests/Coerce.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}++module Coerce where++import Language.KansasLava+import Language.KansasLava.Test++import Data.Sized.Unsigned+import Data.Sized.Matrix as M hiding (length)+import Data.Sized.Signed++type List a = [a]++tests :: TestSeq -> IO ()+tests test = do++ let t1 :: (Bounded w2, Integral w2, Integral w1, Rep w2, Rep w1, Size (W w1), Size (W w2)) =>+ String -> Witness w2 -> List w1 -> IO ()++ t1 str witness arb = testUnsigned test str witness arb++ t1 "U1_U1" (Witness :: Witness U1) ((allCases :: List U1))+ t1 "U2_U1" (Witness :: Witness U2) ((allCases :: List U1))+ t1 "U3_U1" (Witness :: Witness U3) ((allCases :: List U1))+ t1 "U1_U2" (Witness :: Witness U1) ((allCases :: List U2))+ t1 "U2_U2" (Witness :: Witness U2) ((allCases :: List U2))+ t1 "U3_U2" (Witness :: Witness U3) ((allCases :: List U2))+ t1 "U1_U3" (Witness :: Witness U1) ((allCases :: List U3))+ t1 "U2_U3" (Witness :: Witness U2) ((allCases :: List U3))+ t1 "U3_U3" (Witness :: Witness U3) ((allCases :: List U3))+ t1 "U4_U8" (Witness :: Witness U4) ((allCases :: List U8))+ t1 "U8_U4" (Witness :: Witness U8) ((allCases :: List U4))++ t1 "U1_S2" (Witness :: Witness U1) ((allCases :: List S2))+ t1 "U2_S2" (Witness :: Witness U2) ((allCases :: List S2))+ t1 "U3_S2" (Witness :: Witness U3) ((allCases :: List S2))+ t1 "U1_S3" (Witness :: Witness U1) ((allCases :: List S3))+ t1 "U2_S3" (Witness :: Witness U2) ((allCases :: List S3))+ t1 "U3_S3" (Witness :: Witness U3) ((allCases :: List S3))+ t1 "U8_S4" (Witness :: Witness U8) ((allCases :: List S4))++ t1 "X2_X2" (Witness :: Witness X2) ((allCases :: List X2))+ t1 "X2_X3" (Witness :: Witness X2) ((allCases :: List X3))+ t1 "X2_X4" (Witness :: Witness X2) ((allCases :: List X4))+ t1 "X2_X5" (Witness :: Witness X2) ((allCases :: List X5))++ t1 "X3_X2" (Witness :: Witness X3) ((allCases :: List X2))+ t1 "X3_X3" (Witness :: Witness X3) ((allCases :: List X3))+ t1 "X3_X4" (Witness :: Witness X3) ((allCases :: List X4))+ t1 "X3_X5" (Witness :: Witness X3) ((allCases :: List X5))++ t1 "X4_X2" (Witness :: Witness X4) ((allCases :: List X2))+ t1 "X4_X3" (Witness :: Witness X4) ((allCases :: List X3))+ t1 "X4_X4" (Witness :: Witness X4) ((allCases :: List X4))+ t1 "X4_X5" (Witness :: Witness X4) ((allCases :: List X5))++ t1 "X5_X2" (Witness :: Witness X5) ((allCases :: List X2))+ t1 "X5_X3" (Witness :: Witness X5) ((allCases :: List X3))+ 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)) =>+ String -> Witness w2 -> List w1 -> IO ()+ t2 str witness arb = testSigned test str witness arb++ t2 "S2_U1" (Witness :: Witness S2) ((allCases :: List U1))+ t2 "S3_U1" (Witness :: Witness S3) ((allCases :: List U1))+ t2 "S2_U2" (Witness :: Witness S2) ((allCases :: List U2))+ t2 "S3_U2" (Witness :: Witness S3) ((allCases :: List U2))+ t2 "S2_U3" (Witness :: Witness S2) ((allCases :: List U3))+ t2 "S3_U3" (Witness :: Witness S3) ((allCases :: List U3))+ t2 "S4_U8" (Witness :: Witness S4) ((allCases :: List U8))+ t2 "S8_U4" (Witness :: Witness S8) ((allCases :: List U4))++ t2 "S2_S2" (Witness :: Witness S2) ((allCases :: List S2))+ t2 "S3_S2" (Witness :: Witness S3) ((allCases :: List S2))+ t2 "S2_S3" (Witness :: Witness S2) ((allCases :: List S3))+ t2 "S3_S3" (Witness :: Witness S3) ((allCases :: List S3))+ t2 "S4_S8" (Witness :: Witness S4) ((allCases :: List S8))+ t2 "S8_S4" (Witness :: Witness S8) ((allCases :: List S4))++ let t3 :: (Eq w2, Eq w1, Show w1, Show w2, Rep w2, Rep w1, W w2 ~ W w1, Size (W w1)) =>+ String -> Witness w2 -> List w1 -> IO ()+ t3 str witness arb = testBitwise test str witness arb++ t3 "S16_M_X4_S4" (Witness :: Witness S16) ((allCases :: List (Matrix X4 S4)))+ t3 "U15_M_X3_S5" (Witness :: Witness U15) ((allCases :: List (Matrix X3 S5)))+ t3 "U3_M_X3_Bool" (Witness :: Witness U3) ((allCases :: List (Matrix X3 Bool)))+ t3 "U1_M_X1_Bool" (Witness :: Witness U1) ((allCases :: List (Matrix X1 Bool)))+ t3 "Bool_M_X1_Bool" (Witness :: Witness Bool) ((allCases :: List (Matrix X1 Bool)))++ t3 "M_X4_S4_S16" (Witness :: Witness (Matrix X4 S4)) ((allCases :: List S16))+ t3 "M_X3_S5_U15" (Witness :: Witness (Matrix X3 S5)) ((allCases :: List U15))+ t3 "M_X3_Bool_U3" (Witness :: Witness (Matrix X3 Bool)) ((allCases :: List U3))+ t3 "M_X1_Bool_U1" (Witness :: Witness (Matrix X1 Bool)) ((allCases :: List U1))+ t3 "M_X1_Bool_Bool" (Witness :: Witness (Matrix X1 Bool)) ((allCases :: List Bool))++ t3 "U3_x_U2_U5" (Witness :: Witness (U3,U2)) ((allCases :: List U5))+ t3 "U5_U3_x_U2" (Witness :: Witness U5) ((allCases :: List (U3,U2)))+ t3 "U4_U3_x_Bool" (Witness :: Witness U4) ((allCases :: List (U3,Bool)))++ t3 "Bool_U1" (Witness :: Witness Bool) ((allCases :: List U1))+ t3 "U1_Bool" (Witness :: Witness U1) ((allCases :: List Bool))++ t3 "Bool_Bool" (Witness :: Witness Bool) ((allCases :: List Bool))+ t3 "U8_U8" (Witness :: Witness U8) ((allCases :: List U8))++ let t4 :: (Eq w2, Eq w1, Show w1, Show w2, Rep w2, Rep w1, W w2 ~ W w1, Size (W w1)) =>+ String -> Witness w2 -> List w1 -> (w1 -> w2) -> IO ()+ t4 str witness arb f = testCoerce test str witness arb f++ t4 "Bool_U1" (Witness :: Witness Bool) ((allCases :: List U1))+ $ \ u1 -> u1 == 1+ t4 "U1_Bool" (Witness :: Witness U1) ((allCases :: List Bool))+ $ \ b -> if b then 1 else 0+ t4 "Bool_Bool" (Witness :: Witness Bool) ((allCases :: List Bool)) id+ t4 "U8_U8" (Witness :: Witness U8) ((allCases :: List U8)) id++ return ()+++testUnsigned :: forall w1 w2 . (Num w2, Integral w1, Integral w2, Bounded w2, Eq w1, Rep w1, Eq w2, Show w2, Rep w2, Size (W w1), Size (W w2))+ => TestSeq -> String -> Witness w2 -> List w1 -> IO ()+testUnsigned (TestSeq test _) tyName Witness ws = do+ let ms = ws+ cir = unsigned :: Seq w1 -> Seq w2+ driver = do+ outStdLogicVector "i0" (toS ms)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = cir (i0)+ outStdLogicVector "o0" (o0)++ -- will always pass; it *is* the semantics here+ res :: Seq w2+ res = cir $ toS' [ if toInteger m > toInteger (maxBound :: w2)+ || toInteger m < toInteger (minBound :: w2)+ then fail "out of bounds"+ else return m+ | m <- ms+ ]+ test ("unsigned/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)+ return ()++testSigned :: forall w1 w2 . (Num w2, Integral w1, Bounded w1, Integral w2, Bounded w2, Eq w1, Rep w1, Eq w2, Show w2, Rep w2, Size (W w1), Size (W w2))+ => TestSeq -> String -> Witness w2 -> List w1 -> IO ()+testSigned (TestSeq test _) tyName Witness ws = do+ let ms = ws+ cir = signed :: Seq w1 -> Seq w2+ driver = do+ outStdLogicVector "i0" (toS ms)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = cir (i0)+ outStdLogicVector "o0" (o0)++ -- will always pass; it *is* the semantics here+ res :: Seq w2+ res = cir $ toS' [ if (fromIntegral m :: Int) > fromIntegral (maxBound :: w2)+ || (fromIntegral m :: Int) < fromIntegral (minBound :: w2)+ then fail "out of bounds"+ else return m+ | m <- ms+ ]+ test ("signed/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)+ return ()++testBitwise :: forall w1 w2 . (Eq w1, Rep w1, Eq w2, Show w1, Show w2, Rep w2, W w1 ~ W w2, Size (W w2))+ => TestSeq -> String -> Witness w2 -> List w1 -> IO ()+testBitwise (TestSeq test _) tyName Witness ws = do+ let ms = ws+ cir = bitwise :: Seq w1 -> Seq w2+ driver = do+ outStdLogicVector "i0" (toS ms)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = cir (i0)+ outStdLogicVector "o0" (o0)+ -- will always pass; it *is* the semantics here+ res :: Seq w2+ res = cir $ toS ms+ test ("bitwise/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)+ return ()++testCoerce :: forall w1 w2 . (Eq w1, Rep w1, Eq w2, Show w1, Show w2, Rep w2, W w1 ~ W w2, Size (W w2))+ => TestSeq -> String -> Witness w2 -> List w1 -> (w1 -> w2) -> IO ()+testCoerce (TestSeq test _) tyName Witness ws f = do+ let ms = ws+ cir = coerce f :: Seq w1 -> Seq w2+ driver = do+ outStdLogicVector "i0" (toS ms)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = cir (i0)+ outStdLogicVector "o0" (o0)+ -- will always pass; it *is* the semantics here+ res :: Seq w2+ res = cir $ toS ms+ test ("coerce/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)+ return ()
+ tests/GenReport.hs view
@@ -0,0 +1,13 @@+import Language.KansasLava.Test+import System.Environment++main :: IO ()+main = do+ args <- getArgs+ if length args < 1+ then do pname <- getProgName+ putStrLn "Need path to simulation directory."+ putStrLn $ "USAGE: " ++ pname ++ " path"+ putStrLn $ "Example: " ++ pname ++ " sims"+ else generateReport $ args !! 0+
+ tests/Main.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}+module Main where++import Language.KansasLava.Test++import Data.Default+++import qualified Matrix+import qualified Memory+import qualified Coerce+import qualified Others+import qualified Protocols+import qualified Regression++main :: IO ()+main = do+ let opt = def { verboseOpt = 4 -- 4 == show cases that failed+ , testNever = ["max","min","abs","signum"] -- for now+ }+ testDriver opt $ take 6 $ drop 0+ [ Matrix.tests+ , Memory.tests+ , Coerce.tests + , Others.tests+ , Protocols.tests + , Regression.tests+ ]+
+ tests/Makefile view
@@ -0,0 +1,31 @@+DIR := sims+KANSAS_LAVA_ROOT := ..+RUN := env KANSAS_LAVA_ROOT=$(KANSAS_LAVA_ROOT)+N:=2+ARGS:=++runall:+ -make clean+ make test ARGS=--gensim+ make simulate+ make report++test:+ $(RUN) ../dist/build/kansas-lava-unittest/kansas-lava-unittest +RTS -N$(N) -RTS $(ARGS)++simulate:+ $(DIR)/runsims++report:+ $(RUN) ../dist/build/kansas-lava-testreport/kansas-lava-testreport $(DIR)++clean:+ mv $(DIR) XX.$(DIR)+ rm -Rf XX.$(DIR) &++locks:+ find sims -name _lock -print++init:+# Create a symbolic link to the Prelude directory+ ln -s .. KansasLava
+ tests/Matrix.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}++module Matrix where++import Language.KansasLava+import Language.KansasLava.Test++import Data.Sized.Arith+import Data.Sized.Unsigned+import qualified Data.Sized.Matrix as M hiding (length)+import Data.Sized.Ix++type List a = [a]++tests :: TestSeq -> IO ()+tests test = do++ let t1 :: (Size (W w2),+ Size (MUL w1 (W w2)),+ Size w1,+ Rep w2,+ Rep w1,+ Num w2,+ Integral w1) => String -> List (M.Matrix w1 w2) -> IO ()+ t1 str arb = testMatrix1 test str arb++ t1 "X1xU4" (allCases :: List (M.Matrix X1 U4))+ t1 "X2xU4" (allCases :: List (M.Matrix X2 U4))+ t1 "X3xU4" (allCases :: List (M.Matrix X3 U4))++ let t2 :: (Size (MUL w1 (W w2)),+ Size w1,+ Rep w2,+ Rep w1,+ Num w2,+ Integral w1) => String -> List (M.Matrix w1 w2) -> IO ()+ t2 str arb = testMatrix2 test str arb++ t2 "X1xU4" (allCases :: List (M.Matrix X1 U4))+ t2 "X2xU4" (allCases :: List (M.Matrix X2 U4))+ t2 "X3xU4" (allCases :: List (M.Matrix X3 U4))++ let t3 :: (Size (ADD (W w) X1), Rep w, Show w) => String -> List (Maybe w) -> IO ()+ t3 str arb = testMatrix3 test str arb++ t3 "U3" (allCases :: List (Maybe U3))+ t3 "Bool" (allCases :: List (Maybe Bool))++ return ()+++testMatrix1 :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Num w2, Eq w2, Show w2, Rep w2+ , Size (W w2), Size (MUL w1 (W w2)))+ => TestSeq+ -> String+ -> List (M.Matrix w1 w2)+ -> IO ()+testMatrix1 (TestSeq test _) tyName ws = do+ let ms = ws+ cir = sum . M.toList . unpack :: Seq (M.Matrix w1 w2) -> Seq w2+ driver = do+ outStdLogicVector "i0" (bitwise (toS ms) :: Seq (Unsigned (MUL w1 (W w2))))+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = cir i0+ outStdLogicVector "o0" o0+ res = toS [ sum $ M.toList m | m <- ms ] :: Seq w2++ test ("matrix/1/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) ++testMatrix2 :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Eq w2, Show w2, Rep w2, Num w2+ , Size (MUL w1 (W w2)))+ => TestSeq+ -> String+ -> List (M.Matrix w1 w2)+ -> IO ()+testMatrix2 (TestSeq test _) tyName ws = do+ let ms = ws+ cir = pack . (\ m -> M.forAll $ \ i -> m M.! i) . unpack :: Seq (M.Matrix w1 w2) -> Seq (M.Matrix w1 w2)+ driver = do+ return ()+ outStdLogicVector "i0" (bitwise (toS ms) :: Seq (Unsigned (MUL w1 (W w2))))+ dut = do+ return ()+ i0 <- inStdLogicVector "i0"+ let o0 = cir i0+ outStdLogicVector "o0" o0+ res = toS [ m | m <- ms ] :: Seq (M.Matrix w1 w2)++ test ("matrix/2/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res) +++testMatrix3 :: forall w1 .+ (Size (ADD (W w1) X1), Rep w1, Show w1)+ => TestSeq+ -> String+ -> List (Maybe w1)+ -> IO ()+testMatrix3 (TestSeq test _) tyName ws = do+ let ms = ws+ cir :: Seq (Enabled w1) -> Seq (Enabled w1)+ cir = mapEnabled (\ m -> unpackMatrix m M.! (0 :: X2))+ . mapEnabled (\ x -> packMatrix (M.matrix [ x, x ]))+ driver = do+ return ()+ outStdLogicVector "i0" (bitwise (toS ms) :: Seq (Enabled w1))+ dut = do+ return ()+ i0 <- inStdLogicVector "i0"+ let o0 = cir i0+ outStdLogicVector "o0" o0+ res = toS [ m | m <- ms ] :: Seq (Enabled w1)++ test ("matrix/3/" ++ tyName) (length ms) dut (driver >> matchExpected "o0" res)
+ tests/Memory.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}++module Memory where++import Language.KansasLava+import Language.KansasLava.Test++import Data.Sized.Arith+import Data.Sized.Matrix as M hiding (length)+import Data.Sized.Signed+import Data.Sized.Unsigned++import Data.List as List++type List a = [a]++tests :: TestSeq -> IO ()+tests test = do+ -- Memories+ let t1 :: (Eq b, Integral a, Show b,+ Size (W a),+ Size (W (Maybe (a,b))), Size (MUL a (W b)),+ Size a, Rep a, Rep b) =>+ String -> List (Maybe (a,b)) -> IO ()+ t1 str arb = testMatrixMemory test str arb++ t1 "X1xBool" ((finiteCases 1000 :: List (Maybe (X1,Bool))))+ t1 "X1xU4" ((finiteCases 1000 :: List (Maybe (X1,U4))))+ t1 "X2xU4" ((finiteCases 1000 :: List (Maybe (X2,U4))))+ t1 "X4xU4" ((finiteCases 1000 :: List (Maybe (X4,U4))))+ t1 "X16xS10" ((finiteCases 1000 :: List (Maybe (X256,S10))))++ let t2 :: (Eq a, Integral a, Show b,+ Size (W a), Size (W b), Size (MUL a (W b)), Size (W (Maybe (a,b))),+ Size a, Rep a, Rep b, Eq b+ ) =>+ String -> List (Maybe (a,b),a) -> IO ()+ t2 str arb = testSyncMemory test str arb+ t2 "X1xBool" (finiteCases 1000 :: List (Maybe (X1,Bool),X1))+ t2 "X2xU4" ((finiteCases 1000 :: List (Maybe (X2,U4),X2)))+ t2 "X4xU5" ((finiteCases 1000 :: List (Maybe (X4,U5),X4)))++ let t3 :: (Eq a, Integral a, Show b,+ Size (W a), Size (W b), Size (MUL a (W b)), Size (W (Maybe (a,b))),+ Size a, Rep a, Rep b, Eq b+ ) =>+ String -> List (Maybe (a,b),a) -> IO ()+ t3 str arb = testAsyncMemory test str arb+ t3 "X1xBool" ((finiteCases 1000 :: List (Maybe (X1,Bool),X1)))+ t3 "X2xU4" ((finiteCases 1000 :: List (Maybe (X2,U4),X2)))+ t3 "X4xU5" ((finiteCases 1000 :: List (Maybe (X4,U5),X4)))++ -- test ROM+ let t4 :: (Integral a, Size a, Eq a, Rep a,+ Eq b, Show b, Rep b,+ Size (W a), Size (W b)) =>+ String -> List (a,b) -> IO ()+ t4 str arb = testRomMemory test str arb++ t4 "X4xU5" ((finiteCases 1000 :: List (X4,U5)))+ t4 "X4xU8" ((finiteCases 1000 :: List (X4,U8)))+ t4 "X8xB" ((finiteCases 1000 :: List (X8,Bool)))+++testAsyncMemory :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Eq w2, Show w2, Rep w2+ , Size (W w1), Size (W w2)+ , Size (W (Maybe (w1,w2))))+ => TestSeq -> String -> List (Maybe (w1,w2),w1) -> IO ()+testAsyncMemory (TestSeq test _) tyName ws = do+ let (writes,rds) = unzip $ ws+ mem = asyncRead . writeMemory :: Seq (Maybe (w1,w2)) -> Seq w1 -> Seq w2++ driver = do+ outStdLogicVector "writes" (toS writes)+ outStdLogicVector "reads" (toS rds)+ dut = do+ ws' <- inStdLogicVector "writes"+ rs <- inStdLogicVector "reads"+ let o0 = mem (ws') (rs)+ outStdLogicVector "o0" (o0)+ res = shallow++ -- we look backwards in the writes, starting with what was written+ -- in the previous cycle. If we find a write for this address, we+ -- return that as the value. If we find a Nothing, we return Nothing.+ -- If we find a write to another address, we keep looking.+ -- In this way, writing an unknown value invalidates the whole memory.+ shallow :: Seq w2+ shallow = toS' $+ [ List.head+ [ val+ | maybe_ab <- reverse $ take i (Nothing:writes) -- note this gets i-1 writes (up to previous cycle)+ , let (filtr, val) = case maybe_ab of+ Nothing -> (True, Nothing)+ Just (a,b) -> (a == fromIntegral r,Just b)+ , filtr+ ]+ | (i,r) <- zip [1..(length writes-1)] rds+ ]++ test ("memory/async/" ++ tyName) (length writes) dut (driver >> matchExpected "o0" res)++testSyncMemory :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Eq w2, Show w2, Rep w2+ , Size (W w1), Size (W w2)+ , Size (W (Maybe (w1,w2))))+ => TestSeq -> String -> List (Maybe (w1,w2),w1) -> IO ()+testSyncMemory (TestSeq test _) tyName ws = do+ let (writes,rds) = unzip $ ws+ mem = syncRead . writeMemory :: Seq (Maybe (w1,w2)) -> Seq w1 -> Seq w2++ driver = do+ outStdLogicVector "writes" (toS writes)+ outStdLogicVector "reads" (toS rds)+ dut = do+ ws' <- inStdLogicVector "writes"+ rs <- inStdLogicVector "reads"+ let o0 = mem (ws') (rs)+ outStdLogicVector "o0" (o0)+ res = shallow++ -- see note in testAsyncMemory for semantics of generating expected output+ shallow :: Seq w2+ shallow = toS' $+ [ Nothing ] +++ [ List.head+ [ val+ | maybe_ab <- reverse $ take i (Nothing:writes) -- note this gets i-1 writes (up to previous cycle)+ , let (filtr, val) = case maybe_ab of+ Nothing -> (True, Nothing)+ Just (a,b) -> (a == fromIntegral r,Just b)+ , filtr+ ]+ | (i,r) <- zip [1..(length writes-1)] rds+ ]++ test ("memory/sync/" ++ tyName) (length writes) dut (driver >> matchExpected "o0" res)++testMatrixMemory :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Eq w2, Show w2, Rep w2+ , Size (W w1)+ , Size (W (Maybe (w1,w2))), Size (MUL w1 (W w2)))+ => TestSeq -> String -> List (Maybe (w1,w2)) -> IO ()+testMatrixMemory (TestSeq test _) tyName ws = do+ let writes = ws+ mem = memoryToMatrix . writeMemory :: Seq (Maybe (w1,w2)) -> Seq (M.Matrix w1 w2)++ driver = do+ outStdLogicVector "i0" (toS writes)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = mem (i0)+ outStdLogicVector "o0" (o0)+ res = shallow++ -- see note in testAsyncMemory for semantics of generating expected output+ shallow :: Seq (M.Matrix w1 w2)+ shallow = pack+ $ M.matrix+ $ [ toS' $+ [ List.head+ [ val+ | maybe_ab <- reverse $ take i (Nothing:writes) -- note this gets i-1 writes (up to previous cycle)+ , let (filtr, val) = case maybe_ab of+ Nothing -> (True, Nothing)+ Just (a,b) -> (a == fromIntegral x,Just b)+ , filtr+ ]+ | i <- [1..(length writes-1)]+ ]+ | x <- [0..(size (error "witness" :: w1) - 1 )]+ ]++ test ("memory/matrix/" ++ tyName) (length writes) dut (driver >> matchExpected "o0" res)+ return ()++testRomMemory :: forall w1 w2 .+ ( Integral w1, Size w1, Eq w1, Rep w1+ , Eq w2, Show w2, Rep w2+ , Size (W w1), Size (W w2))+ => TestSeq+ -> String+ -> List (w1,w2)+ -> IO ()+testRomMemory (TestSeq test _) tyName ws = do+ let (addr,vals) = unzip $ ws++ m :: Matrix w1 w2+ m = matrix $ take (size (error "" :: w1)) (cycle $ List.nub vals)+ driver = do+ outStdLogicVector "i0" (toS addr)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = mem (i0)+ outStdLogicVector "o0" (o0)+ res = toS [ m M.! a | a <- addr ] :: Seq w2+++ mem = funMap (\ a -> return (m M.! a)) :: Seq w1 -> Seq w2++ test ("memory/async/rom/" ++ tyName) (length addr) dut (driver >> matchExpected "o0" res)+ return ()
+ tests/Others.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}+module Others (tests) where++import Language.KansasLava+import Language.KansasLava.Signal(mkShallowS)+import Language.KansasLava.Test++import qualified Language.KansasLava.Stream as S++import Data.Bits+import Data.Sized.Ix+import Data.Sized.Sampled+import Data.Sized.Signed+import Data.Sized.Unsigned++type List a = [a]++tests :: TestSeq -> IO ()+tests test = do+ -- Just the Num Stuff+ let t1 :: (Fractional a, Ord 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+ -- * make sure there are enough bits to represent+ -- both the fractional and non-fractional part.++ t1 "Sampled/X8xX8" (allCases :: [Sampled X8 X8])+ t1 "Sampled/X1xX4" (allCases :: [Sampled X1 X4])+ t1 "Sampled/X8xX10"(finiteCases 100 :: [Sampled X8 X10])+ 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 ()+ 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 ()+ t2' str arb = testOpsBits2 test str arb++ t2' "U1" (allCases :: List U1)+ t2' "U2" (allCases :: List U2)+ t2' "U3" (allCases :: List U3)+ t2' "U4" (allCases :: List U4)+ t2 "U5" (allCases :: List U5)+ t2 "U6" (allCases :: List U6)+ t2 "U7" (allCases :: List U7)+ t2 "U8" (allCases :: List U8)+ t2 "U32" (finiteCases 100 :: List U32)+{- ghci keeps getting killed during these, Out Of Memory maybe?+ t2 "U64" (finiteCases 100 :: List (Unsigned X64))+-}++ -- no S1+ t2' "S2" (allCases :: List S2)+ t2' "S3" (allCases :: List S3)+ t2' "S4" (allCases :: List S4)+ t2 "S5" (allCases :: List S5)+ t2 "S6" (allCases :: List S6)+ t2 "S7" (allCases :: List S7)+ t2 "S8" (allCases :: List S8)+ t2 "S32" (finiteCases 100 :: List S32)+{- ghci keeps getting killed during these, Out Of Memory maybe?+ t2 "S64" (finiteCases 100 :: List (Signed X64))+-}+ -- Just the Eq Stuff++ -- None++ -- Now registers+ let t3 :: (Eq a, Show a, Rep a, Size (W a)) => String -> List a -> IO ()+ t3 str arb = testRegister test str arb++ t3 "U1" ( (finiteCases 1000 :: List U1))+ t3 "U2" ( (finiteCases 1000 :: List U2))+ t3 "U3" ( (finiteCases 1000 :: List U3))+ t3 "Int" ( (finiteCases 1000 :: List Int))+ t3 "Bool" ( (finiteCases 1000 :: List Bool))++ let t4 :: (Eq a, Show a, Rep a, Size (W a)) => String -> List a -> IO ()+ t4 str arb = testDelay test str arb++ t4 "U1" ( (finiteCases 1000 :: List U1))+ t4 "U2" ( (finiteCases 1000 :: List U2))+ t4 "U3" ( (finiteCases 1000 :: List U3))+ t4 "Int" ( (finiteCases 1000 :: List Int))+ t4 "Bool" ( (finiteCases 1000 :: List Bool))+++{- We are not ready for this yet+ -- Test the flux capacitor+ let t5 :: (Eq a, Show a, Rep a, Size (W a), Size (ADD (W a) X1))+ => String -> List (Maybe a) -> (forall c. (Clock c) => Signal c a -> Signal c a) -> IO ()+ t5 str arb op = testFluxCapacitor test str arb op++ t5 "U5/add" ( (take 1000 inifiniteCases :: List (Maybe U5)))+ $ \ x -> x + 1++ t5 "U5/delay" ( (take 1000 inifiniteCases :: List (Maybe U5)))+ $ delay++ t5 "U5/register" ( (take 1000 inifiniteCases :: List (Maybe U5)))+ $ register 0++ t5 "U5/accum" ( (take 1000 inifiniteCases :: List (Maybe U5)))+ $ \ x -> let r = register 0 (x + r) in r++-}++++data TestMux a = TestMux String (Bool -> a -> a -> a) (forall clk . Signal clk Bool -> Signal clk a -> Signal clk a -> Signal clk a)+data TestCmp a = TestCmp String (a -> a -> Bool) (forall clk . Signal clk a -> Signal clk a -> Signal clk Bool)+--data TestPred a = TestPred String (a -> Bool) (forall clk . Signal clk a -> Signal clk Bool)+data TestUni a = TestUni String (a -> a) (forall clk . Signal clk a -> Signal clk a)+data TestBin a = TestBin String (a -> a -> a) (forall clk . Signal clk a -> Signal clk a -> Signal clk a)+data TestIx a b = TestIx String (a -> b -> Bool) (forall clk . Signal clk a -> Signal clk b -> Signal clk Bool)+++-- This only tests at the *value* level, and ignores testing unknowns.++testUniOp :: forall a b .+ (Rep a, Show a, Size (W a)+ ,Rep b, Show b, Size (W b))+ => TestSeq+ -> String+ -> (a -> b)+ -> (forall clk . Signal clk a -> Signal clk b)+ -> [a]+ -> IO ()+testUniOp (TestSeq test _) nm opr lavaOp us0 = do+ let driver = do+ outStdLogicVector "i0" (toS us0)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = lavaOp (i0)+ outStdLogicVector "o0" (o0)++ res = toS (fmap opr us0)++ test nm (length us0) dut (driver >> matchExpected "o0" res)+++testBinOp :: forall a b c .+ (Rep a, Show a, Size (W a)+ ,Rep b, Show b, Size (W b)+ ,Rep c, Show c, Size (W c))+ => TestSeq+ -> String+ -> (a -> b -> c)+ -> (forall clk . Signal clk a -> Signal clk b -> Signal clk c)+ -> List (a,b)+ -> IO ()+testBinOp (TestSeq test _) nm opr lavaOp gen = do+ let (us0,us1) = unzip gen+ driver = do+ outStdLogicVector "i0" (toS us0)+ outStdLogicVector "i1" (toS us1)+ dut = do+ i0 <- inStdLogicVector "i0"+ i1 <- inStdLogicVector "i1"+ let o0 = lavaOp (i0) (i1)+ outStdLogicVector "o0" (o0)+ res = toS (Prelude.zipWith opr us0 us1)++ test nm (length gen) dut (driver >> matchExpected "o0" res)++testTriOp :: forall a b c d .+ (Rep a, Show a, Size (W a)+ ,Rep b, Show b, Size (W b)+ ,Rep c, Show c, Size (W c)+ ,Rep d, Show d, Size (W d))+ => TestSeq+ -> String+ -> (a -> b -> c -> d)+ -> (forall clk . Signal clk a -> Signal clk b -> Signal clk c -> Signal clk d)+ -> List (a,b,c)+ -> IO ()+testTriOp (TestSeq test _) nm opr lavaOp gen = do+ let (us0,us1,us2) = unzip3 gen+ driver = do+ outStdLogicVector "i0" (toS us0)+ outStdLogicVector "i1" (toS us1)+ outStdLogicVector "i2" (toS us2)+ dut = do+ i0 <- inStdLogicVector "i0"+ i1 <- inStdLogicVector "i1"+ i2 <- inStdLogicVector "i2"+ let o0 = lavaOp (i0) (i1) (i2)+ outStdLogicVector "o0" (o0)+ res = toS (Prelude.zipWith3 opr us0 us1 us2)+ test nm (length gen) dut (driver >> matchExpected "o0" res)++------------------------------------------------------------------------------------------------++testOpsEq :: forall w . (Rep w, Eq w, Show w, Size (W w)) => TestSeq -> String -> List w -> IO ()+testOpsEq test tyName ws = do+ let ws2 = pair ws+ bs = finiteCases (length ws2) :: [Bool]++ sequence_+ [ testTriOp test (name ++ "/" ++ tyName) opr (lavaOp)+ [ (b,w1,w2) | (b,(w1,w2)) <- zip bs ws2 ]+ | TestMux name opr lavaOp <-+ [ TestMux "mux" (\ c a b -> if c then a else b) (\ c a b -> mux c (b,a))+ ]+ ]++ sequence_+ [ testBinOp test (name ++ "/" ++ tyName) opr lavaOp ws2+ | TestCmp name opr lavaOp <-+ [ TestCmp "double-equal" (==) (.==.)+ , TestCmp "not-equal" (/=) (./=.)+ ]+ ]++ return ()++------------------------------------------------------------------------------------------------++testOpsOrd :: (Rep w, Ord w, Show w, Size (W w)) => TestSeq -> String -> List w -> IO ()+testOpsOrd test tyName ws = do+ let ws2 = pair ws++ testOpsEq test tyName ws++ sequence_+ [ testBinOp test (name ++ "/" ++ tyName) opr lavaOp ws2+ | TestCmp name opr lavaOp <-+ [ TestCmp "greater-than" (>) (.>.)+ , TestCmp "less-than" (<) (.<.)+ , TestCmp "gt-equal" (>=) (.>=.)+ , TestCmp "lt-equal" (<=) (.<=.)+ ]+ ]++ return ()++------------------------------------------------------------------------------------------------+++testOpsNum :: forall w .+ (Ord w, Rep w, Num w, Size (W w)) => TestSeq -> String -> List w -> IO ()+testOpsNum test tyName ws = do+ testOpsOrd test tyName ws++ let ws2 = pair ws++ sequence_+ [ testUniOp test (name ++ "/" ++ tyName) opr lavaOp ws+ | TestUni name opr lavaOp <-+ [ TestUni "negate" negate negate+ , TestUni "abs" abs abs+ , TestUni "signum" signum signum+ ]+ ]++ sequence_+ [ testBinOp test (name ++ "/" ++ tyName) opr lavaOp ws2+ | TestBin name opr lavaOp <-+ [ TestBin "add" (+) (+)+ , TestBin "sub" (-) (-)+ , TestBin "mul" (*) (*)+ , TestBin "max" max max+ , TestBin "min" min min+ ]+ ]++ return ()+testOpsFractional :: forall w .+ (Ord w, Rep w, Fractional w, Size (W w)) => TestSeq -> String -> [w] -> IO ()+testOpsFractional test tyName ws = do+ testOpsNum test tyName ws++ -- TODO: add in recip+ sequence_+ [ testUniOp test (name ++ "/" ++ tyName) opr lavaOp ws+ | TestUni name opr lavaOp <-+ -- for now, we *only* divide by powers of two, that we *can* divide by (in range)+ [ TestUni ("divide_by_" ++ show n) (/ (fromIntegral n)) (/ (fromIntegral n))+ | n <- [2,4,8,16,32,64,128,256::Integer]+ , let w = fromInteger n :: w+ , (show n ++ ".0") == show w+ ]+ ]++ return ()++----------------------------------------------------------------------------------------++testOpsBits :: forall w .+ (Ord w, Rep w, Bits w, Size (W w)) => TestSeq -> String -> List w -> IO ()+testOpsBits test tyName ws = do+ testOpsNum test tyName ws++ let ws2 = pair ws++ sequence_+ [ testUniOp test (name ++ "/" ++ tyName) opr lavaOp ws+ | TestUni name opr lavaOp <-+ [ TestUni "complement" complement complement+ ]+ ]++ sequence_+ [ testBinOp test (name ++ "/" ++ tyName) opr lavaOp ws2+ | TestBin name opr lavaOp <-+ [ TestBin "bitwise-and" (.&.) (.&.)+ , TestBin "bitwise-or" (.|.) (.|.)+ , TestBin "xor" (xor) (xor)+ ]+ ]+++ return ()+++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 ()+testOpsBits2 test tyName ws = do+ testOpsBits test tyName ws++ sequence_+ [ testUniOp test (name ++ "/" ++ tyName ++ "/" ++ show rot1)+ opr+ lavaOp+ ws+ | rot0 <- take (bitSize (error "witness" :: w)) [0..] :: [Int]+ , rot1 <- if rot0 == 0 then [rot0] else [rot0,-rot0]+ , let f :: (Bits a) => (a -> Int -> a) -> (a -> a)+ f fn = flip fn (fromIntegral rot1)+ , TestUni name opr lavaOp <-+ [ TestUni "shift" (f shift) (f shift)+ , TestUni "rotate" (f rotate) (f rotate)+ ] ++ if rot1 >= 0 then+ [ TestUni "shiftL" (f shiftL) (f shiftL)+ , TestUni "shiftR" (f shiftR) (f shiftR)+ , TestUni "rotateL" (f rotateL) (f rotateL)+ , TestUni "rotateR" (f rotateR) (f rotateR)+ , TestUni "clearBit" (f clearBit) (f clearBit)+ , TestUni "setBit" (f setBit) (f setBit)+ , TestUni "complementBit" (f complementBit) (f complementBit)+ ] else []+ ]++ let ws2 :: List (w,W w) + ws2 = zip ws (cycle [0..maxBound])+ + sequence_+ [ testBinOp test (name ++ "/" ++ tyName)+ opr+ lavaOp+ ws2+ | TestIx name opr lavaOp <-+ [ TestIx "testABit" (\ a b -> testBit a (fromIntegral b)) (testABit)+ ] + ]++ return ()++pair :: [a] -> [(a, a)]+pair ws = [ (a,b) | a <- ws, b <- ws ]++--------------------------------------------------------------------------------------+-- Testing register and memory+testRegister :: forall a . (Show a, Eq a, Rep a, Size (W a)) => TestSeq -> String -> List a -> IO ()+testRegister (TestSeq test _) tyName ~(u0:us0) = do+ let r = register :: a -> Seq a -> Seq a+ driver = do+ outStdLogicVector "i0" (toS us0)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = r u0 $ i0+ outStdLogicVector "o0" o0+ res = toS (u0 : us0)+ test ("register/" ++ tyName) (length us0) dut (driver >> matchExpected "o0" res)+ return ()++testDelay :: forall a . (Show a, Eq a, Rep a, Size (W a)) => TestSeq -> String -> List a -> IO ()+testDelay (TestSeq test _) tyName (us0) = do+ let dlay = delay :: Seq a -> Seq a+ driver = do+ outStdLogicVector "i0" (toS us0)+ dut = do+ i0 <- inStdLogicVector "i0"+ let o0 = dlay $ i0+ outStdLogicVector "o0" o0++ res = mkShallowS (S.Cons unknownX (Just (S.fromList (map pureX us0))))++ test ("delay/" ++ tyName) (length us0) dut (driver >> matchExpected "o0" res)+ return ()++{-+testFluxCapacitor :: forall a . (Show a, Eq a, Rep a, Size (W a), Size (ADD (W a) X1))+ => TestSeq -> String -> List (Maybe a) -> (forall c . (Clock c) => Signal c a -> Signal c a) -> IO ()+testFluxCapacitor (TestSeq test toL) tyName ws seqOp = do+ let xs = toL ws++ driver = do+ outStdLogicVector "i0" (toS xs :: Seq (Maybe a))+ dut = do+ i0 <- inStdLogicVector "i0" :: Fabric (Seq (Maybe a))+ let o0 = fluxCapacitor seqOp i0 :: Seq (Maybe a)+ outStdLogicVector "o0" o0+++ -- just the results from the internal function+ ys :: [Maybe a]+ ys = fromSeq (seqOp (toS [ x | Just x <- xs ]) :: Seq a)++ -- The xs0 Nothing => not enabled, for ys0 Nothing => Unknown.+ fn :: [Maybe a] -> [Maybe a] -> Stream (X (Maybe a))+ fn (Nothing:xs0) ys0 = Cons (pureX Nothing) (fn xs0 ys0)+ fn (Just {}:xs0) (Just y:ys0) = Cons (pureX (Just y)) (fn xs0 ys0)+ fn _ _ = S.repeat unknownX++ res :: Seq (Maybe a)+ res = shallowSeq (Cons (pureX Nothing) (fn xs ys))+++++ test ("flux-capacitor/" ++ tyName ++ "/") (length xs)+ dut (driver >> matchExpected "o0" res)++ return ()+-}
+ tests/Protocols.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}++module Protocols where++import Language.KansasLava+import Language.KansasLava.Test++import Data.Sized.Ix+import Data.Sized.Unsigned+import Data.Sized.Matrix ((!), matrix, Matrix)+--import qualified Data.Sized.Matrix as M+--import Debug.Trace++tests :: TestSeq -> IO ()+tests test = do+ -- testing Streams++ let fifoTest :: forall w . (Rep w, Eq w, Show w, Size (W w)) + => String+ -> Patch (Seq (Enabled w)) (Seq (Enabled w)) (Seq Ack) (Seq Ack) -> StreamTest w w+ fifoTest n f = StreamTest+ { theStream = f+ , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $+ case () of+ () | outs /= take (length outs) ins -> return "in/out differences"+ () | length outs < fromIntegral count + -> return ("to few transfers: " ++ show (length outs))+ | otherwise -> Nothing++ , theStreamTestCount = count+ , theStreamTestCycles = 10000+ , theStreamName = n+ }+ where+ count = 100++{-+ let bridge' :: forall w . (Rep w,Eq w, Show w, Size (W w)) + => (Seq (Enabled w), Seq Full) -> (Seq Ack, Seq (Enabled w))+ bridge' = bridge `connect` shallowFIFO `connect` bridge+-}++ testStream test "U5" (fifoTest "emptyP" emptyP :: StreamTest U5 U5)+ testStream test "Bool" (fifoTest "emptyP" emptyP :: StreamTest Bool Bool)+ testStream test "U5" (fifoTest "fifo1" fifo1 :: StreamTest U5 U5)+ testStream test "Bool" (fifoTest "fifo1" fifo1 :: StreamTest Bool Bool)+ testStream test "U5" (fifoTest "fifo2" fifo2 :: StreamTest U5 U5)+ testStream test "Bool" (fifoTest "fifo2" fifo2 :: StreamTest Bool Bool)+++ -- This tests dupP and zipP+ let patchTest1 :: forall w . (Rep w,Eq w, Show w, Size (W w), Num w) + => StreamTest w (w,w)+ patchTest1 = StreamTest+ { theStream = dupP $$ fstP (forwardP $ mapEnabled (+1)) $$ zipP+ , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $+-- trace (show (ins,outs)) $ + case () of+ () | length outs /= length ins -> return "in/out differences"+ | any (\ (x,y) -> x - 1 /= y) outs -> return "bad result value"+ | ins /= map snd outs -> return "result not as expected"+ | otherwise -> Nothing++ , theStreamTestCount = count+ , theStreamTestCycles = 10000+ , theStreamName = "dupP-zipP"+ }+ where+ count = 100++ testStream test "U5" (patchTest1 :: StreamTest U5 (U5,U5))+++ -- This tests matrixDupP and matrixZipP+ let patchTest2 :: forall w . (Rep w,Eq w, Show w, Size (W w), Num w) + => StreamTest w (Matrix X3 w)+ patchTest2 = StreamTest+ { theStream = matrixDupP $$ matrixStackP (matrix [ + forwardP $ mapEnabled (+0),+ forwardP $ mapEnabled (+1),+ forwardP $ mapEnabled (+2)] + ) $$ matrixZipP+ , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $+-- trace (show (ins,outs)) $ + case () of+ () | length outs /= length ins -> return "in/out differences"+ | any (\ m -> m ! 0 /= (m ! 1) - 1) outs -> return "bad result value 0,1"+ | any (\ m -> m ! 0 /= (m ! 2) - 2) outs -> return $ "bad result value 0,2"+ | ins /= map (! 0) outs -> return "result not as expected"+ | otherwise -> Nothing++ , theStreamTestCount = count+ , theStreamTestCycles = 10000+ , theStreamName = "matrixDupP-matrixZipP"+ }+ where+ count = 100++ testStream test "U5" (patchTest2 :: StreamTest U5 (Matrix X3 U5))++ -- This tests muxP (and matrixMuxP)+ let patchTest3 :: forall w . (Rep w,Eq w, Show w, Size (W w), Num w, w ~ U5)+ => StreamTest w w+ patchTest3 = StreamTest+ { theStream = + fifo1 $$+ dupP $$ + stackP (forwardP (mapEnabled (*2)) $$ fifo1)+ (forwardP (mapEnabled (*3)) $$ fifo1) $$+ openP $$+ fstP (cycleP (matrix [True,False] :: Matrix X2 Bool) $$ fifo1) $$+ muxP+++ , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $+-- trace (show (ins,outs)) $ + case () of+ () | length outs /= length ins * 2 -> return "in/out size issues"+ | outs /= concat [ [n * 2,n * 3] | n <- ins ]+ -> return "value out distored"+ | otherwise -> Nothing++ , theStreamTestCount = count+ , theStreamTestCycles = 10000+ , theStreamName = "muxP"+ }+ where+ count = 100++ testStream test "U5" (patchTest3 :: StreamTest U5 U5)++ -- This tests deMuxP (and matrixDeMuxP), and zipP+ let patchTest4 :: forall w . (Rep w,Eq w, Show w, Size (W w), Num w, w ~ U5)+ => StreamTest w (w,w)+ patchTest4 = StreamTest+ { theStream = + openP $$+ fstP (cycleP (matrix [True,False] :: Matrix X2 Bool) $$ fifo1) $$+ deMuxP $$+ stackP (fifo1) (fifo1) $$+ zipP + , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $+-- trace (show (ins,outs)) $ + case () of+ () | length outs /= length ins `div` 2 -> return "in/out size issues"+ | concat [ [a,b] | (a,b) <- outs ] /= ins+ -> return "value out distored"+ | otherwise -> Nothing++ , theStreamTestCount = count+ , theStreamTestCycles = 10000+ , theStreamName = "deMuxP-zipP"+ }+ where+ count = 100++ testStream test "U5" (patchTest4 :: StreamTest U5 (U5,U5))+ return ()
+ tests/Regression.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, FlexibleContexts, ExistentialQuantification #-}++module Regression where++import Language.KansasLava+import Language.KansasLava.Test++import Data.Sized.Ix+import Data.Sized.Unsigned+import Data.Sized.Matrix++tests :: TestSeq -> IO ()+tests (TestSeq test _) = do+ let driver1 = outStdLogicVector "i0" res1++ res1 = undefinedS :: Seq X0++ test "regression/1/funMap/Matrix" 1000 fab1 (driver1 >> matchExpected "o0" res1)+ + let res2 = toS $ cycle (True : replicate 15 False)++ test "regression/2/RTL" 1000 fab2 (return () >> matchExpected "o0" res2) ++cir1 :: Signal CLK X0 -> Signal CLK (Matrix X16 U8)+cir1 = funMap fn + where fn _ = return $ matrix [0..15]++fab1 :: Fabric ()+fab1 = do+ a <- inStdLogicVector "i0"+ let b = cir1 a + outStdLogicVector "o0" b++cir2 :: Seq Bool+cir2 = runRTL $ do+ count <- newReg (0 :: (Unsigned X4))+-- CASE [ OTHERWISE $ do count := reg count + 1 ] -- TODO: fix this+ count := reg count + 1 + return (reg count .==. 0)++fab2 :: Fabric ()+fab2 = outStdLogicVector "o0" cir2
+ tools/TBF2VCD.hs view
@@ -0,0 +1,44 @@+module Main where++import Language.KansasLava.VCD+import Control.Applicative+import Data.Char as C+import System.Environment++main :: IO ()+main = do+ cmds <- getArgs+ main2 cmds++main2 :: [String] -> IO ()+main2 ["--diff",sig,inbits,outbits,vcd_out] = main4 sig inbits outbits vcd_out+main2 ["--clock",clk,sig,bits',vcd_out] | all C.isDigit clk+ = main3 True (read clk) sig bits' vcd_out+main2 [clk,sig,bits',vcd_out] | all C.isDigit clk+ = main3 False (read clk) sig bits' vcd_out+main2 _ = error $ "usage:\n kltbf2vcd [--clock] (clockrate-in-ns) <.sig-file> <.bits-file> <vcd-file>\n" +++ " kltbf2vcd --diff <.sig-file> <.left-bits-file> <.right-bits-file> <vcd-file>"++main3 :: Bool -> Integer -> FilePath -> FilePath -> FilePath -> IO ()+main3 ifClk clkRate sigName bitsName vcdFile = do+ sig <- read <$> readFile sigName+ str <- lines <$> readFile bitsName+ writeVCDFile ifClk clkRate vcdFile $ readTBF str sig++main4 :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()+main4 sigfile leftfile rightfile vcdFile = do+ left <- lines <$> readFile leftfile+ right <- lines <$> readFile rightfile+ sig <- read <$> readFile sigfile++ let t1 = readTBF left sig+ t2 = readTBF right sig++ vcdDiff t1 t2 vcdFile++vcdDiff :: VCD -> VCD -> FilePath -> IO ()+vcdDiff (VCD m1) (VCD m2) filePath = writeVCDFile False 10 filePath t+ where t = VCD $ [ ("trace1_" ++ k,v) | (k,v) <- m1 ]+ +++ [ ("trace2_" ++ k,v) | (k,v) <- m2 ]+