module CLasH.Translator
(
makeVHDLAnnotations
) where
import qualified System.Directory as Directory
import qualified Maybe
import qualified Monad
import qualified System.FilePath as FilePath
import qualified Control.Monad.Trans.State as State
import Text.PrettyPrint.HughesPJ (render)
import Data.Accessor.Monad.Trans.State
import qualified Data.Map as Map
import qualified Data.Time.Clock as Clock
import Debug.Trace
import qualified CoreSyn
import qualified HscTypes
import qualified UniqSupply
import qualified Language.VHDL.AST as AST
import qualified Language.VHDL.FileIO as FileIO
import qualified Language.VHDL.Ppr as Ppr
import CLasH.Translator.TranslatorTypes
import CLasH.Translator.Annotations
import CLasH.Utils
import CLasH.Utils.GhcTools
import CLasH.VHDL
import CLasH.VHDL.VHDLTools
import CLasH.VHDL.Testbench
makeVHDLAnnotations ::
FilePath
-> [FilePath]
-> IO ()
makeVHDLAnnotations libdir filenames =
makeVHDL libdir filenames finder
where
finder = findSpec (hasCLasHAnnotation isTopEntity)
(hasCLasHAnnotation isInitState)
(isCLasHAnnotation isInitState)
(hasCLasHAnnotation isTestInput)
makeVHDL ::
FilePath
-> [FilePath]
-> Finder
-> IO ()
makeVHDL libdir filenames finder = do
start <- Clock.getCurrentTime
(cores, env, specs) <- loadModules libdir filenames (Just finder)
vhdl <- moduleToVHDL env cores specs
let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
let dir = "./vhdl/" ++ (show top_entity) ++ "/"
prepareDir dir
mapM_ (writeVHDL dir) vhdl
end <- Clock.getCurrentTime
trace ("\nTotal compilation took " ++ show (Clock.diffUTCTime end start)) $
return ()
moduleToVHDL ::
HscTypes.HscEnv
-> [HscTypes.CoreModule]
-> [EntitySpec]
-> IO [(AST.VHDLId, AST.DesignFile)]
moduleToVHDL env cores specs = do
(vhdl, count) <- runTranslatorSession env $ do
let all_bindings = concatMap (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores
tsBindings %= Map.fromList all_bindings
let all_initstates = concatMap (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs
tsInitStates %= Map.fromList all_initstates
test_binds <- catMaybesM $ Monad.mapM mkTest specs
let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
vhdl <- case topbinds of
[] -> error "Could not find top entity requested"
tops -> createDesignFiles (tops ++ test_binds)
count <- get tsTransformCounter
return (vhdl, count)
mapM_ (putStr . render . Ppr.ppr . snd) vhdl
putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
return vhdl
where
mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
mkTest (_, _, Nothing) = return Nothing
mkTest (Nothing, _, _) = return Nothing
mkTest (Just top, _, Just input) = do
bndr <- createTestbench Nothing cores input top
return $ Just bndr
runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
runTranslatorSession env session = do
uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
return $ State.evalState session init_state
prepareDir :: String -> IO()
prepareDir dir = do
Directory.createDirectoryIfMissing True dir
files <- Directory.getDirectoryContents dir
let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
let abs_to_remove = map (FilePath.combine dir) to_remove
mapM_ Directory.removeFile abs_to_remove
writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
writeVHDL dir (name, vhdl) = do
let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
FileIO.writeDesignFile vhdl fname