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