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 import Debug.Trace
  16
  17 -- GHC API
  18 import qualified CoreSyn
  19 import qualified GHC
  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
  26 import qualified Language.VHDL.Ppr as Ppr
  27
  28 -- Local Imports
  29 import CLasH.Normalize
  30 import CLasH.Translator.TranslatorTypes
  31 import CLasH.Translator.Annotations
  32 import CLasH.Utils
  33 import CLasH.Utils.Core.CoreTools
  34 import CLasH.Utils.GhcTools
  35 import CLasH.VHDL
  36 import CLasH.VHDL.VHDLTools
  37 import CLasH.VHDL.Testbench
  38
  39 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
  40 --   State and Test Inputs.
  41 -- makeVHDLStrings ::
  42 --   FilePath      -- ^ The GHC Library Dir
  43 --   -> [FilePath] -- ^ The FileNames
  44 --   -> String     -- ^ The TopEntity
  45 --   -> String     -- ^ The InitState
  46 --   -> String     -- ^ The TestInput
  47 --   -> IO ()
  48 -- makeVHDLStrings libdir filenames topentity initstate testinput = do
  49 --   makeVHDL libdir filenames finder
  50 --     where
  51 --       finder = findSpec (hasVarName topentity)
  52 --                         (hasVarName initstate)
  53 --                         (isCLasHAnnotation isInitState)
  54 --                         (hasVarName testinput)
  55
  56 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
  57 --   and Test Inputs found in the Files.
  58 makeVHDLAnnotations ::
  59   FilePath      -- ^ The GHC Library Dir
  60   -> [FilePath] -- ^ The FileNames
  61   -> IO ()
  62 makeVHDLAnnotations libdir filenames = do
  63   makeVHDL libdir filenames finder
  64     where
  65       finder = findSpec (hasCLasHAnnotation isTopEntity)
  66                         (hasCLasHAnnotation isInitState)
  67                         (isCLasHAnnotation isInitState)
  68                         (hasCLasHAnnotation isTestInput)
  69
  70 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
  71 --   Entity, Initial State and Test Inputs in the Haskell Files.
  72 makeVHDL ::
  73   FilePath      -- ^ The GHC Library Dir
  74   -> [FilePath] -- ^ The Filenames
  75   -> Finder
  76   -> IO ()
  77 makeVHDL libdir filenames finder = do
  78   -- Load the modules
  79   (cores, env, specs) <- loadModules libdir filenames (Just finder)
  80   -- Translate to VHDL
  81   vhdl <- moduleToVHDL env cores specs
  82   -- Write VHDL to file. Just use the first entity for the name
  83   let top_entity = head $ Maybe.catMaybes $ map (\(t, _, _) -> t) specs
  84   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  85   prepareDir dir
  86   mapM (writeVHDL dir) vhdl
  87   return ()
  88
  89 -- | Translate the specified entities in the given modules to VHDL.
  90 moduleToVHDL ::
  91   HscTypes.HscEnv             -- ^ The GHC Environment
  92   -> [HscTypes.CoreModule]    -- ^ The Core Modules
  93   -> [EntitySpec]             -- ^ The entities to generate
  94   -> IO [(AST.VHDLId, AST.DesignFile)]
  95 moduleToVHDL env cores specs = do
  96   vhdl <- runTranslatorSession env $ do
  97     let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
  98     -- Store the bindings we loaded
  99     tsBindings %= Map.fromList all_bindings
 100     let all_initstates = concat (map (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs)
 101     tsInitStates %= Map.fromList all_initstates
 102     test_binds <- catMaybesM $ Monad.mapM mkTest specs
 103     mapM_ printAnns 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     printAnns :: EntitySpec -> TranslatorSession ()
 119     printAnns (_, Nothing, _) = trace ("no anns found:\n\n") $ return ()
 120     printAnns (_, (Just anns), _) = trace ("anns:\n\n" ++ show anns ++ "\n") $ return ()
 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
 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   Language.VHDL.FileIO.writeDesignFile vhdl fname
 158
 159 -- vim: set ts=8 sw=2 sts=2 expandtab: