module CLaSH.Driver where
import qualified Control.Concurrent.Supply as Supply
import Control.DeepSeq
import Control.Monad (when)
import Control.Monad.State (evalState, get)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as HashSet
import Data.IntMap (IntMap)
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as Text
import qualified Data.Time.Clock as Clock
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified System.IO as IO
import Text.PrettyPrint.Leijen.Text (Doc, hPutDoc)
import Unbound.Generics.LocallyNameless (name2String)
import CLaSH.Annotations.TopEntity (TopEntity)
import CLaSH.Backend
import CLaSH.Core.Term (Term, TmName)
import CLaSH.Core.Type (Type)
import CLaSH.Core.TyCon (TyCon, TyConName)
import CLaSH.Driver.TestbenchGen
import CLaSH.Driver.TopWrapper
import CLaSH.Driver.Types
import CLaSH.Netlist (genComponentName, genNetlist)
import CLaSH.Netlist.Types (Component (..), HWType)
import CLaSH.Normalize (checkNonRecursive, cleanupGraph,
normalize, runNormalization)
import CLaSH.Primitives.Types
generateHDL :: forall backend . Backend backend
=> BindingMap
-> Maybe backend
-> PrimMap
-> HashMap TyConName TyCon
-> IntMap TyConName
-> (HashMap TyConName TyCon -> Type -> Maybe (Either String HWType))
-> (HashMap TyConName TyCon -> Bool -> Term -> Term)
-> (TmName,Maybe TopEntity)
-> Maybe TmName
-> Maybe TmName
-> CLaSHOpts
-> IO ()
generateHDL bindingsMap hdlState primMap tcm tupTcm typeTrans eval (topEntity,annM) testInpM expOutM opts = do
start <- Clock.getCurrentTime
prepTime <- start `deepseq` bindingsMap `deepseq` tcm `deepseq` Clock.getCurrentTime
let prepStartDiff = Clock.diffUTCTime prepTime start
putStrLn $ "Loading dependencies took " ++ show prepStartDiff
(supplyN,supplyTB) <- Supply.splitSupply
. snd
. Supply.freshId
<$> Supply.newSupply
let doNorm = do norm <- normalize [topEntity]
let normChecked = checkNonRecursive topEntity norm
cleanupGraph topEntity normChecked
transformedBindings = runNormalization opts supplyN bindingsMap typeTrans tcm tupTcm eval doNorm
normTime <- transformedBindings `deepseq` Clock.getCurrentTime
let prepNormDiff = Clock.diffUTCTime normTime prepTime
putStrLn $ "Normalisation took " ++ show prepNormDiff
let modName = takeWhile (/= '.') (name2String topEntity)
(netlist,dfiles,cmpCnt) <- genNetlist Nothing transformedBindings primMap tcm
typeTrans Nothing modName [] topEntity
netlistTime <- netlist `deepseq` Clock.getCurrentTime
let normNetDiff = Clock.diffUTCTime netlistTime normTime
putStrLn $ "Netlist generation took " ++ show normNetDiff
let topComponent = head
$ filter (\(Component cName _ _ _ _) ->
Text.isSuffixOf (genComponentName modName topEntity 0)
cName)
netlist
(testBench,dfiles') <- genTestBench opts supplyTB primMap
typeTrans tcm tupTcm eval cmpCnt bindingsMap
testInpM
expOutM
modName
dfiles
topComponent
testBenchTime <- testBench `seq` Clock.getCurrentTime
let netTBDiff = Clock.diffUTCTime testBenchTime netlistTime
putStrLn $ "Testbench generation took " ++ show netTBDiff
let hdlState' = fromMaybe (initBackend :: backend) hdlState
topWrapper = mkTopWrapper primMap annM modName topComponent
hdlDocs = createHDL hdlState' modName (topWrapper : netlist ++ testBench)
dir = concat [ "./" ++ CLaSH.Backend.name hdlState' ++ "/"
, takeWhile (/= '.') (name2String topEntity)
, "/"
]
prepareDir (opt_cleanhdl opts) (extension hdlState') dir
mapM_ (writeHDL hdlState' dir) hdlDocs
copyDataFiles dir dfiles'
end <- hdlDocs `seq` Clock.getCurrentTime
let startEndDiff = Clock.diffUTCTime end start
putStrLn $ "Total compilation took " ++ show startEndDiff
createHDL :: Backend backend
=> backend
-> String
-> [Component]
-> [(String,Doc)]
createHDL backend modName components = flip evalState backend $ do
hdlNmDocs <- mapM (genHDL modName) components
hwtys <- HashSet.toList <$> extractTypes <$> get
typesPkg <- mkTyPackage modName hwtys
return (typesPkg ++ hdlNmDocs)
prepareDir :: Bool
-> String
-> String
-> IO ()
prepareDir cleanhdl ext dir = do
Directory.createDirectoryIfMissing True dir
when cleanhdl $ do
files <- Directory.getDirectoryContents dir
let to_remove = filter ((==ext) . FilePath.takeExtension) files
let abs_to_remove = map (FilePath.combine dir) to_remove
mapM_ Directory.removeFile abs_to_remove
writeHDL :: Backend backend => backend -> FilePath -> (String, Doc) -> IO ()
writeHDL backend dir (cname, hdl) = do
handle <- IO.openFile (dir ++ cname ++ CLaSH.Backend.extension backend) IO.WriteMode
hPutDoc handle hdl
IO.hPutStr handle "\n"
IO.hClose handle
copyDataFiles :: FilePath -> [(String,FilePath)] -> IO ()
copyDataFiles dir = mapM_ copyFile'
where
copyFile' (nm,old) = Directory.copyFile old (dir FilePath.</> nm)