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, count) <- 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     vhdl <- case topbinds of
 106       []  -> error "Could not find top entity requested"
 107       tops -> createDesignFiles (tops ++ test_binds)
 108     count <- get tsTransformCounter
 109     return (vhdl, count)
 110   mapM_ (putStr . render . Ppr.ppr . snd) vhdl
 111   putStr $ "Total number of transformations applied: " ++ (show count) ++ "\n"
 112   return vhdl
 113   where
 114     mkTest :: EntitySpec -> TranslatorSession (Maybe CoreSyn.CoreBndr)
 115     -- Create a testbench for any entry that has test input
 116     mkTest (_, _, Nothing) = return Nothing
 117     mkTest (Nothing, _, _) = return Nothing
 118     mkTest (Just top, _, Just input) = do
 119       bndr <- createTestbench Nothing cores input top
 120       return $ Just bndr
 121
 122 -- Run the given translator session. Generates a new UniqSupply for that
 123 -- session.
 124 runTranslatorSession :: HscTypes.HscEnv -> TranslatorSession a -> IO a
 125 runTranslatorSession env session = do
 126   -- Generate a UniqSupply
 127   -- Running
 128   --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
 129   -- on the compiler dir of ghc suggests that 'z' is not used to generate
 130   -- a unique supply anywhere.
 131   uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 132   let init_typestate = TypeState builtin_types [] Map.empty Map.empty env
 133   let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty 0
 134   return $ State.evalState session init_state
 135
 136 -- | Prepares the directory for writing VHDL files. This means creating the
 137 --   dir if it does not exist and removing all existing .vhdl files from it.
 138 prepareDir :: String -> IO()
 139 prepareDir dir = do
 140   -- Create the dir if needed
 141   Directory.createDirectoryIfMissing True dir
 142   -- Find all .vhdl files in the directory
 143   files <- Directory.getDirectoryContents dir
 144   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
 145   -- Prepend the dirname to the filenames
 146   let abs_to_remove = map (FilePath.combine dir) to_remove
 147   -- Remove the files
 148   mapM_ Directory.removeFile abs_to_remove
 149
 150 -- | Write the given design file to a file with the given name inside the
 151 --   given dir
 152 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 153 writeVHDL dir (name, vhdl) = do
 154   -- Find the filename
 155   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 156   -- Write the file
 157   FileIO.writeDesignFile vhdl fname
 158
 159 -- vim: set ts=8 sw=2 sts=2 expandtab: