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