cλash/CLasH/Translator.hs

   1 module CLasH.Translator
   2   ( makeVHDLStrings
   3   , makeVHDLAnnotations
   4   ) where
   5
   6 -- Standard Modules
   7 import qualified System.Directory as Directory
   8 import qualified Maybe
   9 import qualified Monad
  10 import qualified System.FilePath as FilePath
  11 import qualified Control.Monad.Trans.State as State
  12 import Text.PrettyPrint.HughesPJ (render)
  13 import Data.Accessor
  14 import qualified Data.Map as Map
  15
  16 -- GHC API
  17 import qualified CoreSyn
  18 import qualified GHC
  19 import qualified HscTypes
  20 import qualified UniqSupply
  21
  22 -- VHDL Imports
  23 import qualified Language.VHDL.AST as AST
  24 import qualified Language.VHDL.FileIO
  25 import qualified Language.VHDL.Ppr as Ppr
  26
  27 -- Local Imports
  28 import CLasH.Normalize
  29 import CLasH.Translator.TranslatorTypes
  30 import CLasH.Translator.Annotations
  31 import CLasH.Utils.Core.CoreTools
  32 import CLasH.Utils.GhcTools
  33 import CLasH.VHDL
  34 import CLasH.VHDL.Testbench
  35
  36 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
  37 --   State and Test Inputs.
  38 makeVHDLStrings ::
  39   FilePath      -- ^ The GHC Library Dir
  40   -> [FilePath] -- ^ The FileNames
  41   -> String     -- ^ The TopEntity
  42   -> String     -- ^ The InitState
  43   -> String     -- ^ The TestInput
  44   -> Bool       -- ^ Is it stateful? (in case InitState is empty)
  45   -> IO ()
  46 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
  47   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  48     where
  49       findTopEntity = findBind (hasVarName topentity)
  50       findInitState = findBind (hasVarName initstate)
  51       findTestInput = findExpr (hasVarName testinput)
  52
  53 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
  54 --   and Test Inputs found in the Files.
  55 makeVHDLAnnotations ::
  56   FilePath      -- ^ The GHC Library Dir
  57   -> [FilePath] -- ^ The FileNames
  58   -> Bool       -- ^ Is it stateful? (in case InitState is not specified)
  59   -> IO ()
  60 makeVHDLAnnotations libdir filenames stateful = do
  61   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  62     where
  63       findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
  64       findInitState = findBind (hasCLasHAnnotation isInitState)
  65       findTestInput = findExpr (hasCLasHAnnotation isTestInput)
  66
  67 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
  68 --   Entity, Initial State and Test Inputs in the Haskell Files.
  69 makeVHDL ::
  70   FilePath      -- ^ The GHC Library Dir
  71   -> [FilePath] -- ^ The Filenames
  72   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
  73   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
  74   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
  75   -> Bool       -- ^ Indicates if it is meant to be stateful
  76   -> IO ()
  77 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
  78   -- Load the modules
  79   (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
  80   -- Translate to VHDL
  81   vhdl <- moduleToVHDL env cores top init test stateful
  82   -- Write VHDL to file
  83   let top_entity = Maybe.fromJust $ head top
  84   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  85   prepareDir dir
  86   mapM (writeVHDL dir) vhdl
  87   return ()
  88
  89 -- | Translate the binds with the given names from the given core module to
  90 --   VHDL. The Bool in the tuple makes the function stateful (True) or
  91 --   stateless (False).
  92 moduleToVHDL ::
  93   HscTypes.HscEnv             -- ^ The GHC Environment
  94   -> [HscTypes.CoreModule]    -- ^ The Core Modules
  95   -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
  96   -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
  97   -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
  98   -> Bool                     -- ^ Is it stateful (in case InitState is not specified)
  99   -> IO [(AST.VHDLId, AST.DesignFile)]
 100 moduleToVHDL env cores topbinds' init test stateful = do
 101   let topbinds = Maybe.catMaybes topbinds'
 102   let initialState = Maybe.catMaybes init
 103   let testInput = Maybe.catMaybes test
 104   vhdl <- runTranslatorSession env $ do
 105     let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
 106     -- Store the bindings we loaded
 107     tsBindings %= Map.fromList all_bindings
 108     test_binds <- Monad.zipWithM (createTestbench Nothing) testInput topbinds
 109     createDesignFiles (topbinds ++ test_binds)
 110   mapM (putStr . render . Ppr.ppr . snd) vhdl
 111   return vhdl
 112
 113 -- Run the given translator session. Generates a new UniqSupply for that
 114 -- session.
 115 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
 116 runTranslatorSession env session = do
 117   -- Generate a UniqSupply
 118   -- Running
 119   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
 120   -- on the compiler dir of ghc suggests that 'z' is not used to generate
 121   -- a unique supply anywhere.
 122   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 123   let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
 124   let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty Map.empty Map.empty
 125   return $ State.evalState session init_state
 126
 127 -- | Prepares the directory for writing VHDL files. This means creating the
 128 --   dir if it does not exist and removing all existing .vhdl files from it.
 129 prepareDir :: String -> IO()
 130 prepareDir dir = do
 131   -- Create the dir if needed
 132   Directory.createDirectoryIfMissing True dir
 133   -- Find all .vhdl files in the directory
 134   files <- Directory.getDirectoryContents dir
 135   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
 136   -- Prepend the dirname to the filenames
 137   let abs_to_remove = map (FilePath.combine dir) to_remove
 138   -- Remove the files
 139   mapM_ Directory.removeFile abs_to_remove
 140
 141 -- | Write the given design file to a file with the given name inside the
 142 --   given dir
 143 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 144 writeVHDL dir (name, vhdl) = do
 145   -- Find the filename
 146   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 147   -- Write the file
 148   Language.VHDL.FileIO.writeDesignFile vhdl fname
 149
 150 -- vim: set ts=8 sw=2 sts=2 expandtab: