cλash/CLasH/Translator.hs

   1 {-# LANGUAGE ScopedTypeVariables, RankNTypes, FlexibleContexts #-}
   2
   3 module CLasH.Translator where
   4
   5 import qualified Directory
   6 import qualified System.FilePath as FilePath
   7 import qualified List
   8 import Debug.Trace
   9 import qualified Control.Arrow as Arrow
  10 import GHC hiding (loadModule, sigName)
  11 import CoreSyn
  12 import qualified CoreUtils
  13 import qualified Var
  14 import qualified Type
  15 import qualified TyCon
  16 import qualified DataCon
  17 import qualified HscMain
  18 import qualified SrcLoc
  19 import qualified FastString
  20 import qualified Maybe
  21 import qualified Module
  22 import qualified Data.Foldable as Foldable
  23 import qualified Control.Monad.Trans.State as State
  24 import qualified Control.Monad as Monad
  25 import Name
  26 import qualified Data.Map as Map
  27 import Data.Accessor
  28 import Data.Generics
  29 import NameEnv ( lookupNameEnv )
  30 import qualified HscTypes
  31 import HscTypes ( cm_binds, cm_types )
  32 import MonadUtils ( liftIO )
  33 import Outputable ( showSDoc, ppr, showSDocDebug )
  34 import DynFlags ( defaultDynFlags )
  35 import qualified UniqSupply
  36 import List ( find )
  37 import qualified List
  38 import qualified Monad
  39 import qualified Annotations
  40 import qualified Serialized
  41
  42 -- The following modules come from the ForSyDe project. They are really
  43 -- internal modules, so ForSyDe.cabal has to be modified prior to installing
  44 -- ForSyDe to get access to these modules.
  45 import qualified Language.VHDL.AST as AST
  46 import qualified Language.VHDL.FileIO
  47 import qualified Language.VHDL.Ppr as Ppr
  48 -- This is needed for rendering the pretty printed VHDL
  49 import Text.PrettyPrint.HughesPJ (render)
  50
  51 import CLasH.Translator.TranslatorTypes
  52 import CLasH.Translator.Annotations
  53 import CLasH.Utils.Pretty
  54 import CLasH.Normalize
  55 import CLasH.VHDL.VHDLTypes
  56 import CLasH.Utils.Core.CoreTools
  57 import qualified CLasH.VHDL as VHDL
  58
  59 -- | Turn Haskell to VHDL
  60 makeVHDL ::
  61   FilePath  -- ^ The GHC Library Dir
  62   -> [FilePath] -- ^ The FileNames
  63   -> String -- ^ The TopEntity
  64   -> String -- ^ The InitState
  65   -> String -- ^ The TestInput
  66   -> Bool   -- ^ Is It a stateful (in case InitState is not specified)
  67   -> IO ()
  68 makeVHDL libdir filenames topentity initstate testinput stateful = do
  69   -- Load the modules
  70   (core, top, init, test, env) <- loadModules libdir filenames (findBind topentity) (findBind initstate) (findExpr testinput)
  71   -- Translate to VHDL
  72   vhdl <- moduleToVHDL env core top init test stateful
  73   -- Write VHDL to file
  74   let top_entity = Maybe.fromJust $ head top
  75   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  76   prepareDir dir
  77   mapM (writeVHDL dir) vhdl
  78   return ()
  79
  80 makeVHDLAnn ::
  81   FilePath  -- ^ The GHC Library Dir
  82   -> [FilePath] -- ^ The FileNames
  83   -> Bool   -- ^ Is It a stateful (in case InitState is not specified)
  84   -> IO ()
  85 makeVHDLAnn libdir filenames stateful = do
  86   -- Load the modules
  87   (cores, top, init, test, env) <- loadModules libdir filenames findTopEntity findInitState findTestInput
  88   -- Translate to VHDL
  89   vhdl <- moduleToVHDL env cores top init test stateful
  90   -- Write VHDL to file
  91   let top_entity = Maybe.fromJust $ head top
  92   let dir = "./vhdl/" ++ (show top_entity) ++ "/"
  93   prepareDir dir
  94   mapM (writeVHDL dir) vhdl
  95   return ()
  96     where
  97       findTopEntity = findBindAnn (hasCLasHAnnotation isTopEntity)
  98       findInitState = findBindAnn (hasCLasHAnnotation isInitState)
  99       findTestInput = findExprAnn (hasCLasHAnnotation isTestInput)
 100
 101 -- | Translate the binds with the given names from the given core module to
 102 --   VHDL. The Bool in the tuple makes the function stateful (True) or
 103 --   stateless (False).
 104 moduleToVHDL ::
 105   HscTypes.HscEnv           -- ^ The GHC Environment
 106   -> [HscTypes.CoreModule]  -- ^ The Core Modules
 107   -> [Maybe CoreBndr]       -- ^ The TopEntity
 108   -> [Maybe CoreBndr]       -- ^ The InitState
 109   -> [Maybe CoreExpr]       -- ^ The TestInput
 110   -> Bool                   -- ^ Is it stateful (in case InitState is not specified)
 111   -> IO [(AST.VHDLId, AST.DesignFile)]
 112 moduleToVHDL env cores top init test stateful = do
 113   let topEntity = Maybe.catMaybes top
 114   case topEntity of
 115     [] -> error "Top Entity Not Found"
 116     [topEnt] -> do
 117       let initialState = Maybe.catMaybes init
 118       let isStateful = not (null initialState) || stateful
 119       let testInput = Maybe.catMaybes test
 120       uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
 121       let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (cm_binds x)) cores)
 122       let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
 123       let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
 124       let vhdl = VHDL.createDesignFiles typestate normalized_bindings topEnt test_bindings
 125       mapM (putStr . render . Ppr.ppr . snd) vhdl
 126       return vhdl
 127     xs -> error "More than one topentity found"
 128
 129 -- | Prepares the directory for writing VHDL files. This means creating the
 130 --   dir if it does not exist and removing all existing .vhdl files from it.
 131 prepareDir :: String -> IO()
 132 prepareDir dir = do
 133   -- Create the dir if needed
 134   exists <- Directory.doesDirectoryExist dir
 135   Monad.unless exists $ Directory.createDirectory dir
 136   -- Find all .vhdl files in the directory
 137   files <- Directory.getDirectoryContents dir
 138   let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
 139   -- Prepend the dirname to the filenames
 140   let abs_to_remove = map (FilePath.combine dir) to_remove
 141   -- Remove the files
 142   mapM_ Directory.removeFile abs_to_remove
 143
 144 -- | Write the given design file to a file with the given name inside the
 145 --   given dir
 146 writeVHDL :: String -> (AST.VHDLId, AST.DesignFile) -> IO ()
 147 writeVHDL dir (name, vhdl) = do
 148   -- Find the filename
 149   let fname = dir ++ (AST.fromVHDLId name) ++ ".vhdl"
 150   -- Write the file
 151   Language.VHDL.FileIO.writeDesignFile vhdl fname
 152
 153 -- | Loads the given files and turns it into a core module
 154 loadModules ::
 155   FilePath      -- ^ The GHC Library directory
 156   -> [String]   -- ^ The files that need to be loaded
 157   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
 158   -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
 159   -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
 160   -> IO ( [HscTypes.CoreModule] -- The loaded modules
 161         , [Maybe CoreBndr]  -- The TopEntity
 162         , [Maybe CoreBndr]  -- The InitState
 163         , [Maybe CoreExpr]  -- The TestInput
 164         , HscTypes.HscEnv   -- The Environment corresponding ot the loaded modules
 165         )
 166 loadModules libdir filenames topEntLoc initSLoc testLoc =
 167   defaultErrorHandler defaultDynFlags $ do
 168     runGhc (Just libdir) $ do
 169       dflags <- getSessionDynFlags
 170       setSessionDynFlags dflags
 171       cores <- mapM GHC.compileToCoreModule filenames
 172       env <- GHC.getSession
 173       top_entity <- mapM topEntLoc cores
 174       init_state <- mapM initSLoc cores
 175       test_input <- mapM testLoc cores
 176       return (cores, top_entity, init_state, test_input, env)
 177
 178 findBindAnn ::
 179   GhcMonad m =>
 180   (Var.Var -> m Bool)
 181   -> HscTypes.CoreModule
 182   -> m (Maybe CoreBndr)
 183 findBindAnn annotation core = do
 184   let binds = CoreSyn.flattenBinds $ cm_binds core
 185   annbinds <- Monad.filterM (annotation . fst) binds
 186   let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
 187   return bndr
 188
 189 findExprAnn ::
 190   GhcMonad m =>
 191   (Var.Var -> m Bool)
 192   -> HscTypes.CoreModule
 193   -> m (Maybe CoreExpr)
 194 findExprAnn annotation core = do
 195   let binds = CoreSyn.flattenBinds $ cm_binds core
 196   annbinds <- Monad.filterM (annotation . fst) binds
 197   let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
 198   return exprs
 199
 200 hasCLasHAnnotation ::
 201   GhcMonad m =>
 202   (CLasHAnn -> Bool)
 203   -> Var.Var
 204   -> m Bool
 205 hasCLasHAnnotation clashAnn var = do
 206   let deserializer = Serialized.deserializeWithData
 207   let target = Annotations.NamedTarget (Var.varName var)
 208   (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
 209   let top_ents = filter clashAnn anns
 210   case top_ents of
 211     [] -> return False
 212     xs -> return True
 213
 214 -- | Extracts the named binder from the given module.
 215 findBind ::
 216   GhcMonad m =>
 217   String             -- ^ The Name of the Binder
 218   -> HscTypes.CoreModule   -- ^ The Module to look in
 219   -> m (Maybe CoreBndr) -- ^ The resulting binder
 220 findBind name core =
 221   case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
 222     Nothing -> return Nothing
 223     Just bndr -> return $ Just $ fst bndr
 224
 225 -- | Extracts the named expression from the given module.
 226 findExpr ::
 227   GhcMonad m =>
 228   String             -- ^ The Name of the Binder
 229   -> HscTypes.CoreModule   -- ^ The Module to look in
 230   -> m (Maybe CoreExpr) -- ^ The resulting expression
 231 findExpr name core =
 232   case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
 233     Nothing -> return Nothing
 234     Just bndr -> return $ Just $ snd bndr
 235
 236 -- | Extract a named bind from the given list of binds
 237 findBinder :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
 238 findBinder binds lookfor =
 239   -- This ignores Recs and compares the name of the bind with lookfor,
 240   -- disregarding any namespaces in OccName and extra attributes in Name and
 241   -- Var.
 242   find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
 243
 244 -- vim: set ts=8 sw=2 sts=2 expandtab: