cλash/CLasH/Translator.hs

   1 {-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-}
   2
   3 module CLasH.Translator (makeVHDLStrings, makeVHDLAnnotations) where
   4
   5 -- Standard Modules
   6 import qualified Directory
   7 import qualified Maybe
   8 import qualified Monad
   9 import qualified System.FilePath as FilePath
  10 import Text.PrettyPrint.HughesPJ (render)
  11
  12 -- GHC API
  13 import qualified Annotations
  14 import CoreSyn
  15 import DynFlags ( defaultDynFlags )
  16 import GHC hiding (loadModule, sigName)
  17 import qualified HscTypes
  18 import HscTypes ( cm_binds, cm_types )
  19 import Name
  20 import qualified Serialized
  21 import qualified UniqSupply
  22 import qualified Var
  23
  24 -- VHDL Imports
  25 import qualified Language.VHDL.AST as AST
  26 import qualified Language.VHDL.FileIO
  27 import qualified Language.VHDL.Ppr as Ppr
  28
  29 -- Local Imports
  30 import CLasH.Translator.Annotations
  31 import CLasH.Normalize
  32 import CLasH.Utils.Core.CoreTools
  33 import CLasH.VHDL
  34
  35 -- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
  36 --   State and Test Inputs.
  37 makeVHDLStrings ::
  38   FilePath      -- ^ The GHC Library Dir
  39   -> [FilePath] -- ^ The FileNames
  40   -> String     -- ^ The TopEntity
  41   -> String     -- ^ The InitState
  42   -> String     -- ^ The TestInput
  43   -> Bool       -- ^ Is it stateful? (in case InitState is empty)
  44   -> IO ()
  45 makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
  46   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  47     where
  48       findTopEntity = findBind (hasVarName topentity)
  49       findInitState = findBind (hasVarName initstate)
  50       findTestInput = findExpr (hasVarName testinput)
  51
  52 -- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
  53 --   and Test Inputs found in the Files.
  54 makeVHDLAnnotations ::
  55   FilePath      -- ^ The GHC Library Dir
  56   -> [FilePath] -- ^ The FileNames
  57   -> Bool       -- ^ Is it stateful? (in case InitState is not specified)
  58   -> IO ()
  59 makeVHDLAnnotations libdir filenames stateful = do
  60   makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
  61     where
  62       findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
  63       findInitState = findBind (hasCLasHAnnotation isInitState)
  64       findTestInput = findExpr (hasCLasHAnnotation isTestInput)
  65
  66 -- | Turn Haskell to VHDL, using the given finder functions to find the Top
  67 --   Entity, Initial State and Test Inputs in the Haskell Files.
  68 makeVHDL ::
  69   FilePath      -- ^ The GHC Library Dir
  70   -> [FilePath] -- ^ The Filenames
  71   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Top Entity Finder
  72   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The Init State Finder
  73   -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The Test Input Finder
  74   -> Bool       -- ^ Indicates if it is meant to be stateful
  75   -> IO ()
  76 makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
  77   -- Load the modules
  78   (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
  79   -- Translate to VHDL
  80   vhdl <- moduleToVHDL env cores top init test stateful
  81   -- Write VHDL to file
  82   let top_entity = Maybe.fromJust $ head top
  83   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  84   prepareDir dir
  85   mapM (writeVHDL dir) vhdl
  86   return ()
  87
  88 -- | Translate the binds with the given names from the given core module to
  89 --   VHDL. The Bool in the tuple makes the function stateful (True) or
  90 --   stateless (False).
  91 moduleToVHDL ::
  92   HscTypes.HscEnv           -- ^ The GHC Environment
  93   -> [HscTypes.CoreModule]  -- ^ The Core Modules
  94   -> [Maybe CoreBndr]       -- ^ The TopEntity
  95   -> [Maybe CoreBndr]       -- ^ The InitState
  96   -> [Maybe CoreExpr]       -- ^ The TestInput
  97   -> Bool                   -- ^ Is it stateful (in case InitState is not specified)
  98   -> IO [(AST.VHDLId, AST.DesignFile)]
  99 moduleToVHDL env cores top init test stateful = do
 100   let topEntity = Maybe.catMaybes top
 101   case topEntity of
 102     [] -> error "Top Entity Not Found"
 103     [topEnt] -> do
 104       let initialState = Maybe.catMaybes init
 105       let isStateful = not (null initialState) || stateful
 106       let testInput = Maybe.catMaybes test
 107       uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 108       let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (cm_binds x)) cores)
 109       let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
 110       let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
 111       let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
 112       mapM (putStr . render . Ppr.ppr . snd) vhdl
 113       return vhdl
 114     xs -> error "More than one topentity found"
 115
 116 -- | Prepares the directory for writing VHDL files. This means creating the
 117 --   dir if it does not exist and removing all existing .vhdl files from it.
 118 prepareDir :: String -> IO()
 119 prepareDir dir = do
 120   -- Create the dir if needed
 121   exists <- Directory.doesDirectoryExist dir
 122   Monad.unless exists $ Directory.createDirectory 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 -- | Loads the given files and turns it into a core module
 141 loadModules ::
 142   FilePath      -- ^ The GHC Library directory
 143   -> [String]   -- ^ The files that need to be loaded
 144   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
 145   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
 146   -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
 147   -> IO ( [HscTypes.CoreModule]
 148         , [Maybe CoreBndr]
 149         , [Maybe CoreBndr]
 150         , [Maybe CoreExpr]
 151         , HscTypes.HscEnv
 152         ) -- ^ (The loaded modules , The TopEntity , The InitState, The TestInput, The Environment corresponding ot the loaded modules)
 153 loadModules libdir filenames topEntLoc initSLoc testLoc =
 154   defaultErrorHandler defaultDynFlags $ do
 155     runGhc (Just libdir) $ do
 156       dflags <- getSessionDynFlags
 157       setSessionDynFlags dflags
 158       cores <- mapM GHC.compileToCoreModule filenames
 159       env <- GHC.getSession
 160       top_entity <- mapM topEntLoc cores
 161       init_state <- mapM initSLoc cores
 162       test_input <- mapM testLoc cores
 163       return (cores, top_entity, init_state, test_input, env)
 164
 165 -- | Find a binder in module according to a certain criteria
 166 findBind ::
 167   GhcMonad m =>
 168   (Var.Var -> m Bool)     -- ^ The criteria to filter the binds on
 169   -> HscTypes.CoreModule  -- ^ The module to be inspected
 170   -> m (Maybe CoreBndr)   -- ^ The (first) bind to meet the criteria
 171 findBind annotation core = do
 172   let binds = CoreSyn.flattenBinds $ cm_binds core
 173   annbinds <- Monad.filterM (annotation . fst) binds
 174   let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
 175   return bndr
 176
 177 -- | Find an expresion in module according to a certain criteria
 178 findExpr ::
 179   GhcMonad m =>
 180   (Var.Var -> m Bool)     -- ^ The criteria to filter the binds on
 181   -> HscTypes.CoreModule  -- ^ The module to be inspected
 182   -> m (Maybe CoreExpr)   -- ^ The (first) expr to meet the criteria
 183 findExpr annotation core = do
 184   let binds = CoreSyn.flattenBinds $ cm_binds core
 185   annbinds <- Monad.filterM (annotation . fst) binds
 186   let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
 187   return exprs
 188
 189 -- | Determine if a binder has an Annotation meeting a certain criteria
 190 hasCLasHAnnotation ::
 191   GhcMonad m =>
 192   (CLasHAnn -> Bool)  -- ^ The criteria the Annotation has to meet
 193   -> Var.Var          -- ^ The Binder
 194   -> m Bool           -- ^ Indicates if binder has the Annotation
 195 hasCLasHAnnotation clashAnn var = do
 196   let deserializer = Serialized.deserializeWithData
 197   let target = Annotations.NamedTarget (Var.varName var)
 198   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 199   let annEnts = filter clashAnn anns
 200   case annEnts of
 201     [] -> return False
 202     xs -> return True
 203
 204 -- | Determine if a binder has a certain name
 205 hasVarName ::
 206   GhcMonad m =>
 207   String        -- ^ The name the binder has to have
 208   -> Var.Var    -- ^ The Binder
 209   -> m Bool     -- ^ Indicate if the binder has the name
 210 hasVarName lookfor bind = return $ lookfor == (occNameString $ nameOccName $ getName bind)
 211
 212 -- vim: set ts=8 sw=2 sts=2 expandtab: