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