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