------------------------------------------------------------------------------
--  $Id: XST_VHDL.hs#1 2009/10/01 10:31:09 REDMOND\\satnams $
-------------------------------------------------------------------------------

module Lava.XST_VHDL (putXST_VHDL)
where 
import Lava.Netlist
import Lava.Utils
import Lava.RPM

import System.IO

-------------------------------------------------------------------------------

putXST_VHDL :: String -> RawNetlist -> IO ()
putXST_VHDL circuitName (netCount, instCount, ports, instances, dl)
  = do putStr ("Generating " ++ filename ++ " ...")
       file <- openFile (circuitName++".vhd") WriteMode
       vhdlEntity file circuitName ports
       vhdlArchitecture file circuitName ports instances netCount
       hClose file
       putStrLn " [done]"
    where
    filename = circuitName++".vhd"

-------------------------------------------------------------------------------

vhdlEntity :: Handle -> String -> [Port] -> IO ()
vhdlEntity handle name interface
  = do hPutStr handle (unlines entity)
    where
    entity =
     ["library ieee ;",
      "use ieee.std_logic_1164.all ;",
      "entity " ++ name ++ " is ",
      "  port(" ++ vhdlPorts (reverse interface)] ++
     ["      ) ;",
      "end entity " ++ name ++ " ;",
      ""]
     
-------------------------------------------------------------------------------

vhdlPorts :: [Port] -> String
vhdlPorts intf
  = insertString " ;\n       " (map vhdlPort intf)

-------------------------------------------------------------------------------

vhdlPort :: Port -> String

vhdlPort (InputPort name typ net)
  = name ++ " : in " ++ showType typ


vhdlPort (OutputPort name typ net)
  = name ++ " : out " ++ showType typ   

-------------------------------------------------------------------------------

showType :: TypeExpr -> String
showType WireType = "std_logic"
showType (BitVec low dir high)
   = "std_logic_vector (" ++ show low ++ " " ++ showDir dir ++ " " ++ show high ++
     ")"

-------------------------------------------------------------------------------

showDir :: Dir -> String
showDir To = "to"
showDir Downto = "downto"

-------------------------------------------------------------------------------

vhdlArchitecture :: Handle ->
                    String -> [Port] -> [Instance] -> Int -> IO ()
vhdlArchitecture file name ports netlist netCount
  = do hPutStr file
        (unlines ["library ieee, unisim ;",
          "use ieee.std_logic_1164.all ;",
          "use unisim.vcomponents.all ;",
          "architecture lava of " ++ name ++ " is ",
          "  attribute rloc : string ;",
          netDefs])
       writeRLOCs file netlist
       hPutStr file "begin\n"
       wirePorts file ports
       vhdlInstances file netlist
       hPutStr file "end architecture lava ;\n"
     where
     netDefs :: String
     netDefs = if netCount == 1 then
                  "  -- no local Lava nets"
               else
                  "  signal lava : std_logic_vector (0 to " ++ 
                  show (netCount-1) ++ ") ;"
 
-------------------------------------------------------------------------------

wirePorts :: Handle -> [Port] -> IO ()
wirePorts file = mapM_ (wirePort file)

-------------------------------------------------------------------------------

wirePort :: Handle -> Port -> IO ()

-- Wire up a single bit input port.
wirePort file (InputPort name WireType (Only net))
  = hPutStrLn file ("  lava(" ++ show net ++ ") <= " ++ name ++ ";")

-- Wire up a bit_vector input port.
wirePort file (InputPort name (BitVec low dir high) (Bus nets))
  = sequence_ [hPutStrLn file ("  lava(" ++ show net ++ ") <= " ++ name ++
               "(" ++ show i ++ ");")
               | (Only net, i) <- zip nets (bitvec_indices low dir high)]

-- Wire up a single bit output port.
wirePort file (OutputPort name WireType (Only net))
  = hPutStrLn file ("  " ++ name ++ " <= lava(" ++show  net ++ ") ;")

-- Wire up a bit_vector output port.
wirePort file (OutputPort name (BitVec low dir high) (Bus nets))
  = sequence_ [hPutStrLn file ("  " ++ name ++ "(" ++ show i ++
               ") <= lava(" ++show  net ++ ") ;") 
               | (Only net, i) <- zip nets (bitvec_indices low dir high)]

-------------------------------------------------------------------------------

vhdlInstances :: Handle -> [Instance] -> IO ()
vhdlInstances file netlist
   = mapM_ (vhdlInstance file) netlist

-------------------------------------------------------------------------------
   
vhdlInstance :: Handle -> Instance -> IO ()


-- LUT1
vhdlInstance file (instNumber,
                   Gate Lut1 name pos size b@(UnaryGate behav),
                   inputs, outputs)
   = hPutStrLn file ("  " ++ name ++ "_" ++ show instNumber ++ " : lut1 " ++
                     "generic map (init => \"" ++ showGateBehaviour b ++
                      "\") " ++
                     "port map (" ++ showPMs (zip i inputs ++ zip o outputs)
               ++ ") ;")
     where
     i = ["i0"]
     o = ["o"]

-- LUT2
vhdlInstance file (instNumber,
                   Gate Lut2 name pos size b@(BinaryGate behav),
                   inputs, outputs)
   = hPutStrLn file ("  " ++ name ++ "_" ++ show instNumber ++ " : lut2 " ++
                     "generic map (init => \"" ++ showGateBehaviour b ++
                      "\") " ++
                     "port map (" ++ showPMs (zip i inputs ++ zip o outputs)
               ++ ") ;")
     where
     i = ["i0", "i1"]
     o = ["o"]

-- User defined gate.
vhdlInstance file (instNumber,
                   Gate (LeafGate i o) name pos size behav,
                   inputs, outputs)
   = hPutStrLn file ("  " ++ name ++ "_" ++ show instNumber ++ " : " ++ name
                     ++
                     " port map (" ++ showPMs (zip i inputs ++ zip o outputs)
               ++ ") ;")


-------------------------------------------------------------------------------

showPMs :: [(String, Int)] -> String
showPMs pms = insertString ", " [par ++ "=> lava(" ++ show n ++ ")" |
                                                      (par, n) <- pms]

-------------------------------------------------------------------------------

writeRLOCs :: Handle -> [Instance] -> IO ()
writeRLOCs file netlist
   = mapM_ (writeRLOC file) netlist

-------------------------------------------------------------------------------

writeRLOC :: Handle -> Instance -> IO ()
writeRLOC file (instNumber, primitive, inputs, outputs)
   = if placed pos then
       hPutStrLn file ("  attribute rloc of " ++ inst_name ++ " : label is \"" 
                       ++ showSlice (x,y) ++ "\" ;")
     else
       return ()
     where
     Gate kind name pos size behav = primitive
     At (x,y) = pos
     inst_name = name ++ "_" ++ show instNumber

-------------------------------------------------------------------------------