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 Text.PrettyPrint.HughesPJ (render)
  12
  13 -- GHC API
  14 import qualified CoreSyn
  15 import qualified GHC
  16 import qualified HscTypes
  17 import qualified UniqSupply
  18
  19 -- VHDL Imports
  20 import qualified Language.VHDL.AST as AST
  21 import qualified Language.VHDL.FileIO
  22 import qualified Language.VHDL.Ppr as Ppr
  23
  24 -- Local Imports
  25 import CLasH.Normalize
  26 import CLasH.Translator.Annotations
  27 import CLasH.Utils.Core.CoreTools
  28 import CLasH.Utils.GhcTools
  29 import CLasH.VHDL
  30
  31 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
  32 --   State and Test Inputs.
  33 makeVHDLStrings ::
  34   FilePath      -- ^ The GHC Library Dir
  35   -> [FilePath] -- ^ The FileNames
  36   -> String     -- ^ The TopEntity
  37   -> String     -- ^ The InitState
  38   -> String     -- ^ The TestInput
  39   -> Bool       -- ^ Is it stateful? (in case InitState is empty)
  40   -> IO ()
  41 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
  42   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  43     where
  44       findTopEntity = findBind (hasVarName topentity)
  45       findInitState = findBind (hasVarName initstate)
  46       findTestInput = findExpr (hasVarName testinput)
  47
  48 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
  49 --   and Test Inputs found in the Files.
  50 makeVHDLAnnotations ::
  51   FilePath      -- ^ The GHC Library Dir
  52   -> [FilePath] -- ^ The FileNames
  53   -> Bool       -- ^ Is it stateful? (in case InitState is not specified)
  54   -> IO ()
  55 makeVHDLAnnotations libdir filenames stateful = do
  56   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  57     where
  58       findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
  59       findInitState = findBind (hasCLasHAnnotation isInitState)
  60       findTestInput = findExpr (hasCLasHAnnotation isTestInput)
  61
  62 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
  63 --   Entity, Initial State and Test Inputs in the Haskell Files.
  64 makeVHDL ::
  65   FilePath      -- ^ The GHC Library Dir
  66   -> [FilePath] -- ^ The Filenames
  67   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
  68   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
  69   -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
  70   -> Bool       -- ^ Indicates if it is meant to be stateful
  71   -> IO ()
  72 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
  73   -- Load the modules
  74   (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
  75   -- Translate to VHDL
  76   vhdl <- moduleToVHDL env cores top init test stateful
  77   -- Write VHDL to file
  78   let top_entity = Maybe.fromJust $ head top
  79   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  80   prepareDir dir
  81   mapM (writeVHDL dir) vhdl
  82   return ()
  83
  84 -- | Translate the binds with the given names from the given core module to
  85 --   VHDL. The Bool in the tuple makes the function stateful (True) or
  86 --   stateless (False).
  87 moduleToVHDL ::
  88   HscTypes.HscEnv             -- ^ The GHC Environment
  89   -> [HscTypes.CoreModule]    -- ^ The Core Modules
  90   -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
  91   -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
  92   -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
  93   -> Bool                     -- ^ Is it stateful (in case InitState is not specified)
  94   -> IO [(AST.VHDLId, AST.DesignFile)]
  95 moduleToVHDL env cores top init test stateful = do
  96   let topEntity = Maybe.catMaybes top
  97   case topEntity of
  98     [] -> error "Top Entity Not Found"
  99     [topEnt] -> do
 100       let initialState = Maybe.catMaybes init
 101       let isStateful = not (null initialState) || stateful
 102       let testInput = Maybe.catMaybes test
 103       -- Generate a UniqSupply
 104       -- Running
 105       --    egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
 106       -- on the compiler dir of ghc suggests that 'z' is not used to generate
 107       -- a unique supply anywhere.
 108       uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 109       let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
 110       let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
 111       let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
 112       let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
 113       mapM (putStr . render . Ppr.ppr . snd) vhdl
 114       return vhdl
 115     xs -> error "More than one topentity found"
 116
 117 -- | Prepares the directory for writing VHDL files. This means creating the
 118 --   dir if it does not exist and removing all existing .vhdl files from it.
 119 prepareDir :: String -> IO()
 120 prepareDir dir = do
 121   -- Create the dir if needed
 122   Directory.createDirectoryIfMissing True dir
 123   -- Find all .vhdl files in the directory
 124   files <- Directory.getDirectoryContents dir
 125   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
 126   -- Prepend the dirname to the filenames
 127   let abs_to_remove = map (FilePath.combine dir) to_remove
 128   -- Remove the files
 129   mapM_ Directory.removeFile abs_to_remove
 130
 131 -- | Write the given design file to a file with the given name inside the
 132 --   given dir
 133 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 134 writeVHDL dir (name, vhdl) = do
 135   -- Find the filename
 136   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 137   -- Write the file
 138   Language.VHDL.FileIO.writeDesignFile vhdl fname
 139
 140 -- vim: set ts=8 sw=2 sts=2 expandtab: