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