cλash/CLasH/Translator.hs

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