module Translator where
-import GHC
+import qualified Directory
+import GHC hiding (loadModule, sigName)
import CoreSyn
import qualified CoreUtils
import qualified Var
import qualified Data.Map as Map
import Data.Generics
import NameEnv ( lookupNameEnv )
+import qualified HscTypes
import HscTypes ( cm_binds, cm_types )
import MonadUtils ( liftIO )
import Outputable ( showSDoc, ppr )
import Pretty
import Flatten
import FlattenTypes
+import VHDLTypes
import qualified VHDL
-main =
- do
- defaultErrorHandler defaultDynFlags $ do
- runGhc (Just libdir) $ do
- dflags <- getSessionDynFlags
- setSessionDynFlags dflags
- --target <- guessTarget "adder.hs" Nothing
- --liftIO (print (showSDoc (ppr (target))))
- --liftIO $ printTarget target
- --setTargets [target]
- --load LoadAllTargets
- --core <- GHC.compileToCoreSimplified "Adders.hs"
- core <- GHC.compileToCoreSimplified "Adders.hs"
- --liftIO $ printBinds (cm_binds core)
- let binds = Maybe.mapMaybe (findBind (cm_binds core)) ["sfull_adder"]
- liftIO $ putStr $ prettyShow binds
- -- Turn bind into VHDL
- let (vhdl, sess) = State.runState (mkVHDL binds) (VHDLSession core 0 Map.empty)
- liftIO $ putStr $ render $ ForSyDe.Backend.Ppr.ppr vhdl
- liftIO $ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl "../vhdl/vhdl/output.vhdl"
- liftIO $ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
- return ()
+main = do
+ makeVHDL "Alu.hs" "register_bank" True
+
+makeVHDL :: String -> String -> Bool -> IO ()
+makeVHDL filename name stateful = do
+ -- Load the module
+ core <- loadModule filename
+ -- Translate to VHDL
+ vhdl <- moduleToVHDL core [(name, stateful)]
+ -- Write VHDL to file
+ let dir = "../vhdl/vhdl/" ++ name ++ "/"
+ mapM (writeVHDL dir) vhdl
+ return ()
+
+-- | Show the core structure of the given binds in the given file.
+listBind :: String -> String -> IO ()
+listBind filename name = do
+ core <- loadModule filename
+ let binds = findBinds core [name]
+ putStr "\n"
+ putStr $ prettyShow binds
+ putStr "\n\n"
+ putStr $ showSDoc $ ppr binds
+ putStr "\n\n"
+
+-- | Translate the binds with the given names from the given core module to
+-- VHDL. The Bool in the tuple makes the function stateful (True) or
+-- stateless (False).
+moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [AST.DesignFile]
+moduleToVHDL core list = do
+ let (names, statefuls) = unzip list
+ --liftIO $ putStr $ prettyShow (cm_binds core)
+ let binds = findBinds core names
+ --putStr $ prettyShow binds
+ -- Turn bind into VHDL
+ let (vhdl, sess) = State.runState (mkVHDL binds statefuls) (VHDLSession core 0 Map.empty)
+ mapM (putStr . render . ForSyDe.Backend.Ppr.ppr) vhdl
+ putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
+ return vhdl
+
where
-- Turns the given bind into VHDL
- mkVHDL binds = do
+ mkVHDL binds statefuls = do
-- Add the builtin functions
mapM addBuiltIn builtin_funcs
-- Create entities and architectures for them
- mapM processBind binds
+ Monad.zipWithM processBind statefuls binds
modFuncs nameFlatFunction
- return $ AST.DesignFile
- []
- []
+ modFuncs VHDL.createEntity
+ modFuncs VHDL.createArchitecture
+ VHDL.getDesignFiles
+
+-- | Write the given design file to a file inside the given dir
+-- The first library unit in the designfile must be an entity, whose name
+-- will be used as a filename.
+writeVHDL :: String -> AST.DesignFile -> IO ()
+writeVHDL dir vhdl = do
+ -- Create the dir if needed
+ exists <- Directory.doesDirectoryExist dir
+ Monad.unless exists $ Directory.createDirectory dir
+ -- Find the filename
+ let AST.DesignFile _ (u:us) = vhdl
+ let AST.LUEntity (AST.EntityDec id _) = u
+ let fname = dir ++ AST.fromVHDLId id ++ ".vhdl"
+ -- Write the file
+ ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
+
+-- | Loads the given file and turns it into a core module.
+loadModule :: String -> IO HscTypes.CoreModule
+loadModule filename =
+ defaultErrorHandler defaultDynFlags $ do
+ runGhc (Just libdir) $ do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ --target <- guessTarget "adder.hs" Nothing
+ --liftIO (print (showSDoc (ppr (target))))
+ --liftIO $ printTarget target
+ --setTargets [target]
+ --load LoadAllTargets
+ --core <- GHC.compileToCoreSimplified "Adders.hs"
+ core <- GHC.compileToCoreSimplified filename
+ return core
+-- | Extracts the named binds from the given module.
+findBinds :: HscTypes.CoreModule -> [String] -> [CoreBind]
+findBinds core names = Maybe.mapMaybe (findBind (cm_binds core)) names
+
+-- | Extract a named bind from the given list of binds
findBind :: [CoreBind] -> String -> Maybe CoreBind
findBind binds lookfor =
-- This ignores Recs and compares the name of the bind with lookfor,
-- | Processes the given bind as a top level bind.
processBind ::
- CoreBind -- The bind to process
+ Bool -- ^ Should this be stateful function?
+ -> CoreBind -- ^ The bind to process
-> VHDLState ()
-processBind (Rec _) = error "Recursive binders not supported"
-processBind bind@(NonRec var expr) = do
+processBind _ (Rec _) = error "Recursive binders not supported"
+processBind stateful bind@(NonRec var expr) = do
-- Create the function signature
let ty = CoreUtils.exprType expr
- let hsfunc = mkHsFunction var ty
+ let hsfunc = mkHsFunction var ty stateful
flattenBind hsfunc bind
-- | Flattens the given bind into the given signature and adds it to the
let flatfunc = flattenFunction hsfunc bind
addFunc hsfunc
setFlatFunc hsfunc flatfunc
- let used_hsfuncs = map appFunc (apps flatfunc)
+ let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc)
State.mapM resolvFunc used_hsfuncs
return ()
mkHsFunction ::
Var.Var -- ^ The function defined
-> Type -- ^ The function type (including arguments!)
+ -> Bool -- ^ Is this a stateful function?
-> HsFunction -- ^ The resulting HsFunction
-mkHsFunction f ty =
+mkHsFunction f ty stateful=
HsFunction hsname hsargs hsres
where
hsname = getOccString f
(arg_tys, res_ty) = Type.splitFunTys ty
- -- The last argument must be state
- state_ty = last arg_tys
- state = useAsState (mkHsValueMap state_ty)
- -- All but the last argument are inports
- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
- hsargs = inports ++ [state]
- hsres = case splitTupleType res_ty of
- -- Result type must be a two tuple (state, ports)
- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
- then
- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
- else
- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+ (hsargs, hsres) =
+ if stateful
+ then
+ let
+ -- The last argument must be state
+ state_ty = last arg_tys
+ state = useAsState (mkHsValueMap state_ty)
+ -- All but the last argument are inports
+ inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+ hsargs = inports ++ [state]
+ hsres = case splitTupleType res_ty of
+ -- Result type must be a two tuple (state, ports)
+ Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+ then
+ Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+ else
+ error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+ otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+ in
+ (hsargs, hsres)
+ else
+ -- Just use everything as a port
+ (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-- | Adds signal names to the given FlatFunction
nameFlatFunction ::
HsFunction
-> FuncData
- -> FuncData
+ -> VHDLState ()
nameFlatFunction hsfunc fdata =
let func = flatFunc fdata in
case func of
-- Skip (builtin) functions without a FlatFunction
- Nothing -> fdata
+ Nothing -> do return ()
-- Name the signals in all other functions
Just flatfunc ->
- let s = sigs flatfunc in
- let s' = map (\(Signal id Nothing) -> Signal id (Just $ "sig_" ++ (show id))) s in
- let flatfunc' = flatfunc { sigs = s' } in
- fdata { flatFunc = Just flatfunc' }
+ let s = flat_sigs flatfunc in
+ let s' = map nameSignal s in
+ let flatfunc' = flatfunc { flat_sigs = s' } in
+ setFlatFunc hsfunc flatfunc'
+ where
+ nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+ nameSignal (id, info) =
+ let hints = nameHints info in
+ let parts = ("sig" : hints) ++ [show id] in
+ let name = concat $ List.intersperse "_" parts in
+ (id, info {sigName = Just name})
-- | Splits a tuple type into a list of element types, or Nothing if the type
-- is not a tuple type.
-- | A consise representation of a builtin function
data BuiltIn = BuiltIn String [PortMap] PortMap
+-- | Map a port specification of a builtin function to a VHDL Signal to put in
+-- a VHDLSignalMap
+toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
+toVHDLSignalMap = fmap (\(name, ty) -> Just (VHDL.mkVHDLId name, ty))
+
-- | Translate a concise representation of a builtin function to something
-- that can be put into FuncMap directly.
addBuiltIn :: BuiltIn -> VHDLState ()
addBuiltIn (BuiltIn name args res) = do
addFunc hsfunc
+ setEntity hsfunc entity
where
hsfunc = HsFunction name (map useAsPort args) (useAsPort res)
+ entity = Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res) Nothing
builtin_funcs =
[
projects / matthijs / master-project / cλash.git / blobdiff