module Lava.Vhdl
( writeVhdl
, writeVhdlInput
, writeVhdlInputOutput
)
where
import Lava.Signal
import Lava.Netlist
import Lava.Generic
import Lava.Sequent
import Lava.Error
import Lava.LavaDir
import Data.List
( intersperse
, nub
)
import System.IO
( openFile
, IOMode(..)
, hPutStr
, hClose
)
import System.IO
( stdout
, BufferMode (..)
, hSetBuffering
)
import Data.IORef
import System.Process (system)
import System.Exit (ExitCode(..))
writeVhdl :: (Constructive a, Generic b) => String -> (a -> b) -> IO ()
writeVhdl name circ =
do writeVhdlInput name circ (var "inp")
writeVhdlInput :: (Generic a, Generic b) => String -> (a -> b) -> a -> IO ()
writeVhdlInput name circ inp =
do writeVhdlInputOutput name circ inp (symbolize "outp" (circ inp))
writeVhdlInputOutput :: (Generic a, Generic b)
=> String -> (a -> b) -> a -> b -> IO ()
writeVhdlInputOutput name circ inp out =
do writeItAll name inp (circ inp) out
writeItAll :: (Generic a, Generic b) => String -> a -> b -> b -> IO ()
writeItAll name inp out out' =
do hSetBuffering stdout NoBuffering
putStr ("Writing to file \"" ++ file ++ "\" ... ")
writeDefinitions file name inp out out'
putStrLn "Done."
where
file = name ++ ".vhd"
writeDefinitions :: (Generic a, Generic b)
=> FilePath -> String -> a -> b -> b -> IO ()
writeDefinitions file name inp out out' =
do firstHandle <- openFile firstFile WriteMode
secondHandle <- openFile secondFile WriteMode
var <- newIORef 0
hPutStr firstHandle $ unlines $
[ "-- Generated by Lava 2000"
, ""
, "use work.all;"
, ""
, "entity"
, " " ++ name
, "is"
, "port"
, " -- clock"
, " ( " ++ "clk" ++ " : in bit"
, ""
, " -- inputs"
] ++
[ " ; " ++ v ++ " : in bit"
| VarBool v <- inps
] ++
[ ""
, " -- outputs"
] ++
[ " ; " ++ v ++ " : out bit"
| VarBool v <- outs'
] ++
[ " );"
, "end entity " ++ name ++ ";"
, ""
, "architecture"
, " structural"
, "of"
, " " ++ name
, "is"
]
hPutStr secondHandle $ unlines $
[ "begin"
]
let new =
do n <- readIORef var
let n' = n+1; v = "w" ++ show n'
writeIORef var n'
hPutStr firstHandle (" signal " ++ v ++ " : bit;\n")
return v
define v s =
case s of
Bool True -> port "vdd" []
Bool False -> port "gnd" []
Inv x -> port "inv" [x]
And [] -> define v (Bool True)
And [x] -> port "id" [x]
And [x,y] -> port "and2" [x,y]
And (x:xs) -> define (w 0) (And xs)
>> define v (And [x,w 0])
Or [] -> define v (Bool False)
Or [x] -> port "id" [x]
Or [x,y] -> port "or2" [x,y]
Or (x:xs) -> define (w 0) (Or xs)
>> define v (Or [x,w 0])
Xor [] -> define v (Bool False)
Xor [x] -> port "id" [x]
Xor [x,y] -> port "xor2" [x,y]
Xor (x:xs) -> define (w 0) (Or xs)
>> define (w 1) (Inv (w 0))
>> define (w 2) (And [x, w 1])
>> define (w 3) (Inv x)
>> define (w 4) (Xor xs)
>> define (w 5) (And [w 3, w 4])
>> define v (Or [w 2, w 5])
VarBool s -> port "id" [s]
DelayBool x y -> port "delay" [x, y]
_ -> wrong Lava.Error.NoArithmetic
where
w i = v ++ "_" ++ show i
port name args =
do hPutStr secondHandle $
" "
++ make 9 ("c_" ++ v)
++ " : entity "
++ make 5 name
++ " port map ("
++ concat (intersperse ", " ("clk" : args ++ [v]))
++ ");\n"
outvs <- netlistIO new define (struct out)
hPutStr secondHandle $ unlines $
[ ""
, " -- naming outputs"
]
sequence
[ define v' (VarBool v)
| (v,v') <- flatten outvs `zip` [ v' | VarBool v' <- outs' ]
]
hPutStr secondHandle $ unlines $
[ "end structural;"
]
hClose firstHandle
hClose secondHandle
system ("cat " ++ firstFile ++ " " ++ secondFile ++ " > " ++ file)
system ("rm " ++ firstFile ++ " " ++ secondFile)
return ()
where
sigs x = map unsymbol . flatten . struct $ x
inps = sigs inp
outs' = sigs out'
firstFile = file ++ "-1"
secondFile = file ++ "-2"
make n s = take (n `max` length s) (s ++ repeat ' ')