diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Language/KansasLava.hs b/Language/KansasLava.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava.hs @@ -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 + + diff --git a/Language/KansasLava/DOT.hs b/Language/KansasLava/DOT.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/DOT.hs @@ -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] + diff --git a/Language/KansasLava/Dynamic.hs b/Language/KansasLava/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Dynamic.hs @@ -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 _ = [] diff --git a/Language/KansasLava/Entity.hs b/Language/KansasLava/Entity.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Entity.hs @@ -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) diff --git a/Language/KansasLava/Fabric.hs b/Language/KansasLava/Fabric.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Fabric.hs @@ -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 diff --git a/Language/KansasLava/Internal.hs b/Language/KansasLava/Internal.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Internal.hs @@ -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 + + diff --git a/Language/KansasLava/Netlist/Decl.hs b/Language/KansasLava/Netlist/Decl.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Netlist/Decl.hs @@ -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 + ] diff --git a/Language/KansasLava/Netlist/Inst.hs b/Language/KansasLava/Netlist/Inst.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Netlist/Inst.hs @@ -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" diff --git a/Language/KansasLava/Netlist/Utils.hs b/Language/KansasLava/Netlist/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Netlist/Utils.hs @@ -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] => , 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" diff --git a/Language/KansasLava/Optimization.hs b/Language/KansasLava/Optimization.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Optimization.hs @@ -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) + ] + + diff --git a/Language/KansasLava/Probes.hs b/Language/KansasLava/Probes.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Probes.hs @@ -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 diff --git a/Language/KansasLava/Protocols.hs b/Language/KansasLava/Protocols.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols.hs @@ -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 diff --git a/Language/KansasLava/Protocols/AckBox.hs b/Language/KansasLava/Protocols/AckBox.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/AckBox.hs @@ -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) + diff --git a/Language/KansasLava/Protocols/Enabled.hs b/Language/KansasLava/Protocols/Enabled.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/Enabled.hs @@ -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 + diff --git a/Language/KansasLava/Protocols/Memory.hs b/Language/KansasLava/Protocols/Memory.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/Memory.hs @@ -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 + +--------------------------------- diff --git a/Language/KansasLava/Protocols/Patch.hs b/Language/KansasLava/Protocols/Patch.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/Patch.hs @@ -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 +-} diff --git a/Language/KansasLava/Protocols/ReadyBox.hs b/Language/KansasLava/Protocols/ReadyBox.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/ReadyBox.hs @@ -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) diff --git a/Language/KansasLava/Protocols/Types.hs b/Language/KansasLava/Protocols/Types.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Protocols/Types.hs @@ -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 + +------------------------------------------------------------------------------------------------------------------------------------------------ + diff --git a/Language/KansasLava/RTL.hs b/Language/KansasLava/RTL.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/RTL.hs @@ -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 diff --git a/Language/KansasLava/Rep.hs b/Language/KansasLava/Rep.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Rep.hs @@ -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 + diff --git a/Language/KansasLava/Rep/Class.hs b/Language/KansasLava/Rep/Class.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Rep/Class.hs @@ -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] + ] + + + + diff --git a/Language/KansasLava/Rep/TH.hs b/Language/KansasLava/Rep/TH.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Rep/TH.hs @@ -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)) + + +-} diff --git a/Language/KansasLava/Signal.hs b/Language/KansasLava/Signal.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Signal.hs @@ -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 + diff --git a/Language/KansasLava/Stream.hs b/Language/KansasLava/Stream.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Stream.hs @@ -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 diff --git a/Language/KansasLava/Test.hs b/Language/KansasLava/Test.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Test.hs @@ -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 [ "" + , "" + , "" + , "
Shallow Failures:" ++ show (sfail s) ++ "(" ++ show (total s - sfail s) ++ "/" ++ show (total s) ++ " passed)
Simulation Failures:" ++ show (sum [codegenfail s, vhdlfail s, compfail s, simfail s]) ++ + "(" ++ show (passed s) ++ "/" ++ show (total s - sfail s) ++ " passed)
" + , "
" + , "" + , "" + , "" + , "" + , "" + , "
VHDL Generation Failures:" ++ show (codegenfail s) ++ "
VHDL Compilation Failures:" ++ show (vhdlfail s) ++ "
Comparison Failures:" ++ show (compfail s) ++ "
Other Simulation Failures:" ++ show (simfail s) ++ "
" + ] + 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 = "Show All" + res = unlines [ concat ["
", name + ,"", s, "
\n
" + , "
"] + | (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 -> "
" ++ sliceString 200 80 s ++ "
" ++ 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 diff --git a/Language/KansasLava/Types.hs b/Language/KansasLava/Types.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Types.hs @@ -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 -> ix -> n + proj :: G -> +-} + +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 _) = "" + show (BlackBox _) = "" + 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) = "" + +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 + diff --git a/Language/KansasLava/Utils.hs b/Language/KansasLava/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/Utils.hs @@ -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) + diff --git a/Language/KansasLava/VCD.hs b/Language/KansasLava/VCD.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/VCD.hs @@ -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 ] + diff --git a/Language/KansasLava/VCD/EventList.hs b/Language/KansasLava/VCD/EventList.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/VCD/EventList.hs @@ -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 diff --git a/Language/KansasLava/VHDL.hs b/Language/KansasLava/VHDL.hs new file mode 100644 --- /dev/null +++ b/Language/KansasLava/VHDL.hs @@ -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 ]) diff --git a/Prelude/HTML/footer.inc b/Prelude/HTML/footer.inc new file mode 100644 --- /dev/null +++ b/Prelude/HTML/footer.inc @@ -0,0 +1,2 @@ + + diff --git a/Prelude/HTML/header.inc b/Prelude/HTML/header.inc new file mode 100644 --- /dev/null +++ b/Prelude/HTML/header.inc @@ -0,0 +1,63 @@ + + + Kansas Lava Unit Tests + + + + + +
diff --git a/Prelude/HTML/mid.inc b/Prelude/HTML/mid.inc new file mode 100644 --- /dev/null +++ b/Prelude/HTML/mid.inc @@ -0,0 +1,2 @@ +
+ diff --git a/Prelude/VHDL/Lava.vhd b/Prelude/VHDL/Lava.vhd new file mode 100644 --- /dev/null +++ b/Prelude/VHDL/Lava.vhd @@ -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; + diff --git a/Prelude/VHDL/Modelsim.vhd b/Prelude/VHDL/Modelsim.vhd new file mode 100644 --- /dev/null +++ b/Prelude/VHDL/Modelsim.vhd @@ -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; diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/kansas-lava.cabal b/kansas-lava.cabal new file mode 100644 --- /dev/null +++ b/kansas-lava.cabal @@ -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 +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 diff --git a/tests/Coerce.hs b/tests/Coerce.hs new file mode 100644 --- /dev/null +++ b/tests/Coerce.hs @@ -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 () diff --git a/tests/GenReport.hs b/tests/GenReport.hs new file mode 100644 --- /dev/null +++ b/tests/GenReport.hs @@ -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 + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 + ] + diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -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 diff --git a/tests/Matrix.hs b/tests/Matrix.hs new file mode 100644 --- /dev/null +++ b/tests/Matrix.hs @@ -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) diff --git a/tests/Memory.hs b/tests/Memory.hs new file mode 100644 --- /dev/null +++ b/tests/Memory.hs @@ -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 () diff --git a/tests/Others.hs b/tests/Others.hs new file mode 100644 --- /dev/null +++ b/tests/Others.hs @@ -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 () +-} diff --git a/tests/Protocols.hs b/tests/Protocols.hs new file mode 100644 --- /dev/null +++ b/tests/Protocols.hs @@ -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 () diff --git a/tests/Regression.hs b/tests/Regression.hs new file mode 100644 --- /dev/null +++ b/tests/Regression.hs @@ -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 diff --git a/tools/TBF2VCD.hs b/tools/TBF2VCD.hs new file mode 100644 --- /dev/null +++ b/tools/TBF2VCD.hs @@ -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> \n" ++ + " kltbf2vcd --diff <.sig-file> <.left-bits-file> <.right-bits-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 ] +