module Language.KansasLava.VHDL(netlistCircuit, 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
writeVhdlCircuit :: String -> FilePath -> KLEG -> IO ()
writeVhdlCircuit nm file cir = do
nlMod <- netlistCircuit nm cir
writeFile file (genVHDL nlMod mods)
where
mods = ["work.lava.all","work.all"]
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)]) ++
[");"]
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);",
"\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
pause n = "\t\twait for " ++ (show (n * clockSpeed `div` (10 ::Int))) ++ " ns;"
outputRange = show (portLen (ins ++ outs) 1) ++ " downto " ++ show (portLen outs)
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"]]
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]
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"
netlistCircuit :: String
-> KLEG
-> IO Module
netlistCircuit name circ = do
let (KLEG nodes srcs sinks) = preprocessNetlistCircuit circ
let inports = checkPortType srcs
let outports = checkPortType (map outputNameAndType sinks)
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)
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
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..(n1)]]
other -> error $ show ("srcs",other)
]
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..(n1)]]
other -> error $ show ("sinks",other)
]
nodesOut :: [(Unique, Entity Unique)]
nodesOut = [ (u,Entity (Prim "unconcat")
[('o':show j,innerTy) | j <- [0..(n1)]]
[("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 ])