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
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 Prelude
import System.Process
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 qualified Language.KansasLava.Stream as S
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
data TestSeq = TestSeq
(String -> Int -> Fabric () -> (Fabric (Int -> Maybe String)) -> IO ())
()
type SimMods = [(String,KLEG -> IO KLEG)]
testFabrics
:: Options
-> SimMods
-> String
-> Int
-> Fabric ()
-> (Fabric (Int -> Maybe String))
-> 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
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
]
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
return Nothing)
| (modname, action) <- sims
, let rep = report (name </> modname)
, let vrb = verbose (verboseOpt opts) (name </> modname)
]
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"
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
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
else do verb 3 "simulation failed"
report $ CompareFail
else do verb 3 "VHDL compilation failed"
report $ CompileFail
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
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)
allCases :: (Rep w) => [w]
allCases = Maybe.catMaybes $ fmap f [0..(n1)]
where (Gen n f) = arbitrary
finiteCases :: (Rep w) => Int ->[w]
finiteCases i = take i $ Maybe.catMaybes $ fmap f $ R.randomRs (0,n1) (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
buildResults :: FilePath -> IO [TestCase]
buildResults spath = go "" spath
where go :: String -> FilePath -> IO [TestCase]
go name path = do
resE <- doesFileExist $ path </> "result"
res <- if resE
then liftM (\r -> [(name,r)]) (read <$> (Strict.readFile $ path </> "result"))
else return []
contents <- getDirectoryContents path
subdirs <- filterM (\(_,f) -> doesDirectoryExist f)
[ (name </> f, path </> f)
| f <- contents
, f /= "."
, f /= ".." ]
subresults <- concat <$> (mapM (uncurry go) subdirs)
return $ res ++ subresults
addtoSummary :: Result -> Summary -> Summary
addtoSummary (ShallowFail {}) s = s { sfail = 1 + (sfail s) }
addtoSummary ShallowPass s = s { spass = 1 + (spass s) }
addtoSummary SimGenerated s = s { generated = 1 + (generated s) }
addtoSummary (CodeGenFail {}) s = s { codegenfail = 1 + (codegenfail s) }
addtoSummary (CompileFail {}) s = s { vhdlfail = 1 + (vhdlfail s) }
addtoSummary (SimFail {}) s = s { simfail = 1 + (simfail s) }
addtoSummary (CompareFail {}) s = s { compfail = 1 + (compfail s) }
addtoSummary (TestAborted) s = s { testaborted = 1 + (testaborted s) }
addtoSummary (Pass {}) s = s { passed = 1 + (passed s) }
buildReport :: [TestCase] -> Report
buildReport rs = Report summary rs
where rs' = map snd rs
summary = foldr addtoSummary (Summary 0 0 0 0 0 0 0 0 0 (length rs')) rs'
reportToSummaryHtml :: Report -> IO String
reportToSummaryHtml (Report summary _) = do
header <- readPreludeFile "Prelude/HTML/header.inc"
mid <- readPreludeFile "Prelude/HTML/mid.inc"
footer <- readPreludeFile "Prelude/HTML/footer.inc"
return $ header ++ (summaryToHtml summary) ++ mid ++ footer
summaryToHtml :: Summary -> String
summaryToHtml s = unlines [ "<table>"
, "<tr class=\"huge " ++ sclass ++ "\"><td>Shallow Failures:</td><td>" ++ show (sfail s) ++ "</td><td>(" ++ show (total s sfail s) ++ "/" ++ show (total s) ++ " passed)</td></tr>"
, "<tr class=\"huge " ++ dclass ++ "\"><td>Simulation Failures:</td><td>" ++ show (sum [codegenfail s, vhdlfail s, compfail s, simfail s]) ++
"</td><td>(" ++ show (passed s) ++ "/" ++ show (total s sfail s) ++ " passed)</td></tr>"
, "</table>"
, "<hr width=\"90%\">"
, "<table>"
, "<tr id=\"cgf\" class=\"kindahuge\"><td>VHDL Generation Failures:</td><td>" ++ show (codegenfail s) ++ "</td></tr>"
, "<tr id=\"vcf\" class=\"kindahuge\"><td>VHDL Compilation Failures:</td><td>" ++ show (vhdlfail s) ++ "</td></tr>"
, "<tr id=\"cpf\" class=\"kindahuge\"><td>Comparison Failures:</td><td>" ++ show (compfail s) ++ "</td></tr>"
, "<tr id=\"osf\" class=\"kindahuge\"><td>Other Simulation Failures:</td><td>" ++ show (simfail s) ++ "</td></tr>"
, "</table>"
]
where chooser x = case x of
0 -> "allpass"
i | i == total s -> "allfail"
_ -> "somepass"
sclass = chooser $ sfail s
dclass = chooser $ total s sfail s passed s
reportToHtml :: Report -> IO String
reportToHtml (Report summary results) = do
header <- readPreludeFile "Prelude/HTML/header.inc"
mid <- readPreludeFile "Prelude/HTML/mid.inc"
footer <- readPreludeFile "Prelude/HTML/footer.inc"
let showall = "<a href=\"#\" id=\"showall\">Show All</a>"
res = unlines [ concat ["<div id=\"", name, "\" class=\"header ", sc, "\">", name
,"<span class=\"status\">", s, "</span></div>\n<div class=\"additional\">"
, "</div>"]
| (name, r) <- results
, let (sc, s) = case r of
ShallowFail {}-> ("shallowfail", "Shallow Failed")
ShallowPass -> ("shallowpass", "Shallow Passed")
SimGenerated -> ("simgenerated", "Simulation Generated")
CodeGenFail {} -> ("codegenfail", "VHDL Generation Failed")
CompileFail {} -> ("compilefail", "VHDL Compilation Failed")
SimFail {} -> ("simfail", "Simulation Failed (other)")
CompareFail {} -> ("comparefail", "Failed")
TestAborted {} -> ("testabort", "Test Aborted")
Pass {} -> ("pass", "Passed")
]
return $ header ++ (summaryToHtml summary) ++ mid ++ showall ++ res ++ footer
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 ()
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)
)
()
sequence_ [ t test
| t <- tests
]
sequence_ [ do stop <- newEmptyMVar
putMVar work (Left stop)
takeMVar stop
| _ <- [1..thread_count]
]
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
, runSim :: Bool
, simCmd :: String
, simPath :: FilePath
, permuteMods :: Bool
, verboseOpt :: Int
, testOnly :: Maybe [String]
, testNever :: [String]
, testData :: Int
, parTest :: Int
} 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 ]
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."
}
type TestCase = (String, Result)
data Result = ShallowFail
| ShallowPass
| SimGenerated
| CodeGenFail
| CompileFail
| SimFail
| CompareFail
| TestAborted
| Pass
deriving (Show, Read)
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..]
]
let
cir = theStream streamTest
driver :: Fabric (Int -> Maybe String)
driver = do
ack <- inStdLogic "ack" :: Fabric (Seq Ack)
let vals2 :: Seq (Enabled w1)
(_,vals2) = toAckBox' a (vals ++ Prelude.repeat Nothing,ack)
outStdLogicVector "vals" (enabledVal vals2)
outStdLogic "vals_en" (isEnabled vals2)
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 ]
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]
d = cycle [0..4]
test ("stream/" ++ theStreamName streamTest ++ "/" ++ tyName) (length vals) dut driver
readPreludeFile :: String -> IO String
readPreludeFile fname = do
ks <- getEnv "KANSAS_LAVA_ROOT"
Strict.readFile (ks </> fname)
`E.catch` \ (_ :: IOException) -> do
path <- getDataFileName fname
Strict.readFile path
`E.catch` \ (_ :: IOException) -> do
putStrLn "Set the KANSAS_LAVA_ROOT environment variable"
putStrLn "to point to the root of the KsLava source directory."
exitFailure
mkTestbench' :: FilePath
-> Int
-> (KLEG -> IO KLEG)
-> Fabric ()
-> [(String,Pad)]
-> 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