-{-# LANGUAGE ScopedTypeVariables #-}
+module CLasH.Translator
+ ( makeVHDLStrings
+ , makeVHDLAnnotations
+ ) where
-module CLasH.Translator where
-
-import qualified Directory
-import qualified System.FilePath as FilePath
-import qualified List
-import Debug.Trace
-import qualified Control.Arrow as Arrow
-import GHC hiding (loadModule, sigName)
-import CoreSyn
-import qualified CoreUtils
-import qualified Var
-import qualified Type
-import qualified TyCon
-import qualified DataCon
-import qualified HscMain
-import qualified SrcLoc
-import qualified FastString
+-- Standard Modules
+import qualified System.Directory as Directory
import qualified Maybe
-import qualified Module
-import qualified Data.Foldable as Foldable
-import qualified Control.Monad.Trans.State as State
-import qualified Control.Monad as Monad
-import Name
-import qualified Data.Map as Map
-import Data.Accessor
-import Data.Generics
-import NameEnv ( lookupNameEnv )
+import qualified Monad
+import qualified System.FilePath as FilePath
+import Text.PrettyPrint.HughesPJ (render)
+
+-- GHC API
+import qualified CoreSyn
+import qualified GHC
import qualified HscTypes
-import HscTypes ( cm_binds, cm_types )
-import MonadUtils ( liftIO )
-import Outputable ( showSDoc, ppr, showSDocDebug )
-import DynFlags ( defaultDynFlags )
import qualified UniqSupply
-import List ( find )
-import qualified List
-import qualified Monad
-import qualified Annotations
-import qualified Serialized
--- The following modules come from the ForSyDe project. They are really
--- internal modules, so ForSyDe.cabal has to be modified prior to installing
--- ForSyDe to get access to these modules.
+-- VHDL Imports
import qualified Language.VHDL.AST as AST
import qualified Language.VHDL.FileIO
import qualified Language.VHDL.Ppr as Ppr
--- This is needed for rendering the pretty printed VHDL
-import Text.PrettyPrint.HughesPJ (render)
-import CLasH.Translator.TranslatorTypes
-import CLasH.Translator.Annotations
-import CLasH.Utils.Pretty
+-- Local Imports
import CLasH.Normalize
-import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.Annotations
import CLasH.Utils.Core.CoreTools
-import qualified CLasH.VHDL as VHDL
-
--- makeVHDL :: FilePath -> String -> String -> Bool -> IO ()
--- makeVHDL libdir filename name stateful = do
--- -- Load the module
--- (core, env) <- loadModule libdir filename
--- -- Translate to VHDL
--- vhdl <- moduleToVHDL env core [(name, stateful)]
--- -- Write VHDL to file
--- let dir = "./vhdl/" ++ name ++ "/"
--- prepareDir dir
--- mapM (writeVHDL dir) vhdl
--- return ()
-
-makeVHDLAnn :: FilePath -> String -> IO ()
-makeVHDLAnn libdir filename = do
- (core, top, init, test, env) <- loadModuleAnn libdir filename
- let top_entity = head top
- let test_expr = head test
- vhdl <- case init of
- [] -> moduleToVHDLAnn env core (top_entity, test_expr)
- xs -> moduleToVHDLAnnState env core (top_entity, test_expr, (head xs))
+import CLasH.Utils.GhcTools
+import CLasH.VHDL
+
+-- | Turn Haskell to VHDL, Usings Strings to indicate the Top Entity, Initial
+-- State and Test Inputs.
+makeVHDLStrings ::
+ FilePath -- ^ The GHC Library Dir
+ -> [FilePath] -- ^ The FileNames
+ -> String -- ^ The TopEntity
+ -> String -- ^ The InitState
+ -> String -- ^ The TestInput
+ -> Bool -- ^ Is it stateful? (in case InitState is empty)
+ -> IO ()
+makeVHDLStrings libdir filenames topentity initstate testinput stateful = do
+ makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+ where
+ findTopEntity = findBind (hasVarName topentity)
+ findInitState = findBind (hasVarName initstate)
+ findTestInput = findExpr (hasVarName testinput)
+
+-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
+-- and Test Inputs found in the Files.
+makeVHDLAnnotations ::
+ FilePath -- ^ The GHC Library Dir
+ -> [FilePath] -- ^ The FileNames
+ -> Bool -- ^ Is it stateful? (in case InitState is not specified)
+ -> IO ()
+makeVHDLAnnotations libdir filenames stateful = do
+ makeVHDL libdir filenames findTopEntity findInitState findTestInput stateful
+ where
+ findTopEntity = findBind (hasCLasHAnnotation isTopEntity)
+ findInitState = findBind (hasCLasHAnnotation isInitState)
+ findTestInput = findExpr (hasCLasHAnnotation isTestInput)
+
+-- | Turn Haskell to VHDL, using the given finder functions to find the Top
+-- Entity, Initial State and Test Inputs in the Haskell Files.
+makeVHDL ::
+ FilePath -- ^ The GHC Library Dir
+ -> [FilePath] -- ^ The Filenames
+ -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Top Entity Finder
+ -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreBndr)) -- ^ The Init State Finder
+ -> (HscTypes.CoreModule -> GHC.Ghc (Maybe CoreSyn.CoreExpr)) -- ^ The Test Input Finder
+ -> Bool -- ^ Indicates if it is meant to be stateful
+ -> IO ()
+makeVHDL libdir filenames topEntFinder initStateFinder testInputFinder stateful = do
+ -- Load the modules
+ (cores, top, init, test, env) <- loadModules libdir filenames topEntFinder initStateFinder testInputFinder
+ -- Translate to VHDL
+ vhdl <- moduleToVHDL env cores top init test stateful
+ -- Write VHDL to file
+ let top_entity = Maybe.fromJust $ head top
let dir = "./vhdl/" ++ (show top_entity) ++ "/"
prepareDir dir
mapM (writeVHDL dir) vhdl
return ()
-listBindings :: FilePath -> String -> IO [()]
-listBindings libdir filename = do
- (core, env) <- loadModule libdir filename
- let binds = CoreSyn.flattenBinds $ cm_binds core
- mapM (listBinding) binds
-
-listBinding :: (CoreBndr, CoreExpr) -> IO ()
-listBinding (b, e) = do
- putStr "\nBinder: "
- putStr $ show b
- putStr "\nType of Binder: \n"
- putStr $ showSDoc $ ppr $ Var.varType b
- putStr "\n\nExpression: \n"
- putStr $ prettyShow e
- putStr "\n\n"
- putStr $ showSDoc $ ppr e
- putStr "\n\nType of Expression: \n"
- putStr $ showSDoc $ ppr $ CoreUtils.exprType e
- putStr "\n\n"
-
--- | Show the core structure of the given binds in the given file.
-listBind :: FilePath -> String -> String -> IO ()
-listBind libdir filename name = do
- (core, env) <- loadModule libdir filename
- let [(b, expr)] = findBinds core [name]
- listBinding (b, expr)
-
-- | 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.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
--- moduleToVHDL env core list = do
--- let (names, statefuls) = unzip list
--- let binds = map fst $ findBinds core names
--- -- Generate a UniqSupply
--- -- Running
--- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
--- -- on the compiler dir of ghc suggests that 'z' is not used to generate a
--- -- unique supply anywhere.
--- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
--- -- Turn bind into VHDL
--- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
--- let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
--- let vhdl = VHDL.createDesignFiles typestate normalized_bindings binds
--- mapM (putStr . render . Ppr.ppr . snd) vhdl
--- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
--- return vhdl
-
-moduleToVHDLAnn :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDLAnn env core (topbind, test) = do
- -- Generate a UniqSupply
- -- Running
- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
- -- on the compiler dir of ghc suggests that 'z' is not used to generate a
- -- unique supply anywhere.
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- -- Turn bind into VHDL
- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
- let testexprs = reduceCoreListToHsList test
- let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [False]
- let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
- return vhdl
-
-moduleToVHDLAnnState :: HscTypes.HscEnv -> HscTypes.CoreModule -> (CoreSyn.CoreBndr, CoreSyn.CoreExpr, CoreSyn.CoreBndr) -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDLAnnState env core (topbind, test, init_state) = do
- -- Generate a UniqSupply
- -- Running
- -- egrep -r "(initTcRnIf|mkSplitUniqSupply)" .
- -- on the compiler dir of ghc suggests that 'z' is not used to generate a
- -- unique supply anywhere.
- uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
- -- Turn bind into VHDL
- let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
- let testexprs = reduceCoreListToHsList test
- let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topbind] [True]
- let vhdl = VHDL.createDesignFiles typestate normalized_bindings topbind test_bindings
- mapM (putStr . render . Ppr.ppr . snd) vhdl
- --putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
- return vhdl
+moduleToVHDL ::
+ HscTypes.HscEnv -- ^ The GHC Environment
+ -> [HscTypes.CoreModule] -- ^ The Core Modules
+ -> [Maybe CoreSyn.CoreBndr] -- ^ The TopEntity
+ -> [Maybe CoreSyn.CoreBndr] -- ^ The InitState
+ -> [Maybe CoreSyn.CoreExpr] -- ^ The TestInput
+ -> Bool -- ^ Is it stateful (in case InitState is not specified)
+ -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env cores top init test stateful = do
+ let topEntity = Maybe.catMaybes top
+ case topEntity of
+ [] -> error "Top Entity Not Found"
+ [topEnt] -> do
+ let initialState = Maybe.catMaybes init
+ let isStateful = not (null initialState) || stateful
+ let testInput = Maybe.catMaybes test
+ uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
+ let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
+ let testexprs = case testInput of [] -> [] ; [x] -> reduceCoreListToHsList x
+ let (normalized_bindings, test_bindings, typestate) = normalizeModule env uniqSupply all_bindings testexprs [topEnt] [isStateful]
+ let vhdl = createDesignFiles typestate normalized_bindings topEnt test_bindings
+ mapM (putStr . render . Ppr.ppr . snd) vhdl
+ return vhdl
+ xs -> error "More than one topentity found"
-- | Prepares the directory for writing VHDL files. This means creating the
-- dir if it does not exist and removing all existing .vhdl files from it.
prepareDir :: String -> IO()
prepareDir dir = do
-- Create the dir if needed
- exists <- Directory.doesDirectoryExist dir
- Monad.unless exists $ Directory.createDirectory dir
+ Directory.createDirectoryIfMissing True dir
-- Find all .vhdl files in the directory
files <- Directory.getDirectoryContents dir
let to_remove = filter ((==".vhdl") . FilePath.takeExtension) files
-- Write the file
Language.VHDL.FileIO.writeDesignFile vhdl fname
--- | Loads the given file and turns it into a core module.
-loadModule :: FilePath -> String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
-loadModule libdir 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.compileToCoreModule filename
- env <- GHC.getSession
- return (core, env)
-
--- | Loads the given file and turns it into a core module.
-loadModuleAnn :: FilePath -> String -> IO (HscTypes.CoreModule, [CoreSyn.CoreBndr], [CoreSyn.CoreBndr], [CoreSyn.CoreExpr], HscTypes.HscEnv)
-loadModuleAnn libdir 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.compileToCoreModule filename
- env <- GHC.getSession
- top_entity <- findTopEntity core
- init_state <- findInitState core
- test_input <- findTestInput core
- return (core, top_entity, init_state, test_input, env)
-
-findTopEntity :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
-findTopEntity core = do
- let binds = CoreSyn.flattenBinds $ cm_binds core
- topbinds <- Monad.filterM (hasTopEntityAnnotation . fst) binds
- let bndrs = case topbinds of [] -> error $ "Couldn't find top entity in current module." ; xs -> fst (unzip topbinds)
- return bndrs
-
-findInitState :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreBndr]
-findInitState core = do
- let binds = CoreSyn.flattenBinds $ cm_binds core
- statebinds <- Monad.filterM (hasInitStateAnnotation . fst) binds
- let bndrs = case statebinds of [] -> [] ; xs -> fst (unzip statebinds)
- return bndrs
-
-findTestInput :: GhcMonad m => HscTypes.CoreModule -> m [CoreSyn.CoreExpr]
-findTestInput core = do
- let binds = CoreSyn.flattenBinds $ cm_binds core
- testbinds <- Monad.filterM (hasTestInputAnnotation . fst) binds
- let exprs = case testbinds of [] -> [] ; xs -> snd (unzip testbinds)
- return exprs
-
-hasTopEntityAnnotation :: GhcMonad m => Var.Var -> m Bool
-hasTopEntityAnnotation var = do
- let deserializer = Serialized.deserializeWithData
- let target = Annotations.NamedTarget (Var.varName var)
- (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
- let top_ents = filter isTopEntity anns
- case top_ents of
- [] -> return False
- xs -> return True
-
-hasInitStateAnnotation :: GhcMonad m => Var.Var -> m Bool
-hasInitStateAnnotation var = do
- let deserializer = Serialized.deserializeWithData
- let target = Annotations.NamedTarget (Var.varName var)
- (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
- let top_ents = filter isInitState anns
- case top_ents of
- [] -> return False
- xs -> return True
-
-hasTestInputAnnotation :: GhcMonad m => Var.Var -> m Bool
-hasTestInputAnnotation var = do
- let deserializer = Serialized.deserializeWithData
- let target = Annotations.NamedTarget (Var.varName var)
- (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
- let top_ents = filter isTestInput anns
- case top_ents of
- [] -> return False
- xs -> return True
-
--- | Extracts the named binds from the given module.
-findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
-findBinds core names = Maybe.mapMaybe (findBind (CoreSyn.flattenBinds $ cm_binds core)) names
-
--- | Extract a named bind from the given list of binds
-findBind :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
-findBind binds lookfor =
- -- This ignores Recs and compares the name of the bind with lookfor,
- -- disregarding any namespaces in OccName and extra attributes in Name and
- -- Var.
- find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
-
--- | Flattens the given bind into the given signature and adds it to the
--- session. Then (recursively) finds any functions it uses and does the same
--- with them.
--- flattenBind ::
--- HsFunction -- The signature to flatten into
--- -> (CoreBndr, CoreExpr) -- The bind to flatten
--- -> TranslatorState ()
---
--- flattenBind hsfunc bind@(var, expr) = do
--- -- Flatten the function
--- let flatfunc = flattenFunction hsfunc bind
--- -- Propagate state variables
--- let flatfunc' = propagateState hsfunc flatfunc
--- -- Store the flat function in the session
--- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
--- -- Flatten any functions used
--- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
--- mapM_ resolvFunc used_hsfuncs
-
--- | Decide which incoming state variables will become state in the
--- given function, and which will be propagate to other applied
--- functions.
--- propagateState ::
--- HsFunction
--- -> FlatFunction
--- -> FlatFunction
---
--- propagateState hsfunc flatfunc =
--- flatfunc {flat_defs = apps', flat_sigs = sigs'}
--- where
--- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
--- states' = zip olds news
--- -- Find all signals used by all sigdefs
--- uses = concatMap sigDefUses (flat_defs flatfunc)
--- -- Find all signals that are used more than once (is there a
--- -- prettier way to do this?)
--- multiple_uses = uses List.\\ (List.nub uses)
--- -- Find the states whose "old state" signal is used only once
--- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
--- -- See if these single use states can be propagated
--- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
--- substate_sigs = concat substate_sigss
--- -- Mark any propagated state signals as SigSubState
--- sigs' = map
--- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
--- (flat_sigs flatfunc)
-
--- | Propagate the state into a single function application.
--- propagateState' ::
--- [(SignalId, SignalId)]
--- -- ^ TODO
--- -> SigDef -- ^ The SigDef to process.
--- -> ([SignalId], SigDef)
--- -- ^ Any signal ids that should become substates,
--- -- and the resulting application.
---
--- propagateState' states def =
--- if (is_FApp def) then
--- (our_old ++ our_new, def {appFunc = hsfunc'})
--- else
--- ([], def)
--- where
--- hsfunc = appFunc def
--- args = appArgs def
--- res = appRes def
--- our_states = filter our_state states
--- -- A state signal belongs in this function if the old state is
--- -- passed in, and the new state returned
--- our_state (old, new) =
--- any (old `Foldable.elem`) args
--- && new `Foldable.elem` res
--- (our_old, our_new) = unzip our_states
--- -- Mark the result
--- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
--- res' = fmap (mark_state (zip our_new [0..])) zipped_res
--- -- Mark the args
--- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
--- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
--- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
---
--- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
--- mark_state states (id, use) =
--- case lookup id states of
--- Nothing -> use
--- Just state_id -> State state_id
-
--- | Returns pairs of signals that should be mapped to state in this function.
--- getStateSignals ::
--- HsFunction -- | The function to look at
--- -> FlatFunction -- | The function to look at
--- -> [(SignalId, SignalId)]
--- -- | TODO The state signals. The first is the state number, the second the
--- -- signal to assign the current state to, the last is the signal
--- -- that holds the new state.
---
--- getStateSignals hsfunc flatfunc =
--- [(old_id, new_id)
--- | (old_num, old_id) <- args
--- , (new_num, new_id) <- res
--- , old_num == new_num]
--- where
--- sigs = flat_sigs flatfunc
--- -- Translate args and res to lists of (statenum, sigid)
--- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
--- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
-
--- | Find the given function, flatten it and add it to the session. Then
--- (recursively) do the same for any functions used.
--- resolvFunc ::
--- HsFunction -- | The function to look for
--- -> TranslatorState ()
---
--- resolvFunc hsfunc = do
--- flatfuncmap <- getA tsFlatFuncs
--- -- Don't do anything if there is already a flat function for this hsfunc or
--- -- when it is a builtin function.
--- Monad.unless (Map.member hsfunc flatfuncmap) $ do
--- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
--- -- New function, resolve it
--- core <- getA tsCoreModule
--- -- Find the named function
--- let name = (hsFuncName hsfunc)
--- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
--- case bind of
--- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
--- Just b -> flattenBind hsfunc b
-
--- | Translate a top level function declaration to a HsFunction. i.e., which
--- interface will be provided by this function. This function essentially
--- defines the "calling convention" for hardware models.
--- 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 stateful=
--- HsFunction hsname hsargs hsres
--- where
--- hsname = getOccString f
--- (arg_tys, res_ty) = Type.splitFunTys ty
--- (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 ::
--- FlatFunction
--- -> FlatFunction
---
--- nameFlatFunction flatfunc =
--- -- Name the signals
--- let
--- s = flat_sigs flatfunc
--- s' = map nameSignal s in
--- flatfunc { flat_sigs = s' }
--- 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.
--- splitTupleType ::
--- Type -- ^ The type to split
--- -> Maybe [Type] -- ^ The tuples element types
---
--- splitTupleType ty =
--- case Type.splitTyConApp_maybe ty of
--- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
--- then
--- Just args
--- else
--- Nothing
--- Nothing -> Nothing
-
-- vim: set ts=8 sw=2 sts=2 expandtab:
-{-# LANGUAGE PackageImports #-}
-
module CLasH.VHDL.Generate where
-- Standard modules
-import qualified Control.Monad as Monad
import qualified Data.Map as Map
import qualified Maybe
import qualified Data.Either as Either
-import qualified Control.Monad.Trans.State as State
-import qualified "transformers" Control.Monad.Identity as Identity
import Data.Accessor
import Data.Accessor.MonadState as MonadState
import Debug.Trace
import qualified Language.VHDL.AST as AST
-- GHC API
-import CoreSyn
-import Type
+import qualified CoreSyn
+import qualified Type
import qualified Var
import qualified IdInfo
import qualified Literal
genSizedInt :: BuiltinBuilder
genSizedInt = genFromInteger
+-- | Generate a Builder for the builtin datacon TFVec
genTFVec :: BuiltinBuilder
-genTFVec (Left res) f [Left veclist] = do {
- ; let (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) = veclist
- ; let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- ; let valargs = get_val_args (Var.varType f) args
- ; apps <- genApplication (Left bndr) f (map Left valargs)
- ; (aap,kooi) <- reduceFSVECListToHsList rez
- ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (bndr:aap)
- ; let vecsigns = concatsigs sigs
- ; let vecassign = mkUncondAssign (Left res) vecsigns
- ; sig_dec_maybes <- mapM mkSigDec (bndr:aap)
- ; let sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
- ; let block_label = mkVHDLExtId ("FSVec_" ++ (show (map varToString (bndr:aap))))
- ; let block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs (apps ++ kooi ++ [vecassign])
+genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
+ -- Generate Assignments for all the binders
+ ; letAssigns <- mapM genBinderAssign letBinders
+ -- Generate assignments for the result (which might be another let binding)
+ ; (resBinders,resAssignments) <- genResAssign letRes
+ -- Get all the Assigned binders
+ ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
+ -- Make signal names for all the assigned binders
+ ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
+ -- Assign all the signals to the resulting vector
+ ; let { vecsigns = mkAggregateSignal sigs
+ ; vecassign = mkUncondAssign (Left res) vecsigns
+ } ;
+ -- Generate all the signal declaration for the assigned binders
+ ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
+ ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
+ -- Setup the VHDL Block
+ ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
+ } ;
+ -- Return the block statement coressponding to the TFVec literal
; return $ [AST.CSBSm block]
}
where
- concatsigs x = AST.Aggregate (map (\z -> AST.ElemAssoc Nothing z) x)
-
-
-reduceFSVECListToHsList app@(CoreSyn.App _ letexpr) = do
- case letexpr of
- (CoreSyn.Let (CoreSyn.Rec [(bndr, app@(CoreSyn.App _ _))]) rez) -> do
+ genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
+ -- For now we only translate applications
+ genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
let valargs = get_val_args (Var.varType f) args
- app <- genApplication (Left bndr) f (map Left valargs)
- (vars, apps) <- reduceFSVECListToHsList rez
- return ((bndr:vars),(app ++ apps))
- otherwise -> return ([],[])
+ apps <- genApplication (Left bndr) f (map Left valargs)
+ return (Just bndr, apps)
+ genBinderAssign _ = return (Nothing,[])
+ genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
+ genResAssign app@(CoreSyn.App _ letexpr) = do
+ case letexpr of
+ (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
+ letapps <- mapM genBinderAssign letbndrs
+ let bndrs = Maybe.catMaybes (map fst letapps)
+ let app = (map snd letapps)
+ (vars, apps) <- genResAssign letres
+ return ((bndrs ++ vars),((concat app) ++ apps))
+ otherwise -> return ([],[])
+ genResAssign _ = return ([],[])
+
+genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
+ ; let { elems = reduceCoreListToHsList app
+ -- Make signal names for all the binders
+ ; binders = map (\expr -> case expr of
+ (CoreSyn.Var b) -> b
+ otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
+ ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
+ } ;
+ ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders
+ -- Assign all the signals to the resulting vector
+ ; let { vecsigns = mkAggregateSignal sigs
+ ; vecassign = mkUncondAssign (Left res) vecsigns
+ -- Setup the VHDL Block
+ ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
+ ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
+ } ;
+ -- Return the block statement coressponding to the TFVec literal
+ ; return $ [AST.CSBSm block]
+ }
+
+genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
+genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
-genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
+genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
-- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
-- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
-- we must index it (which we couldn't if it was a VHDL Expr, since only
-- An expression for len-1
let len_min_expr = (AST.PrimLit $ show (len-1))
-- evec is (TFVec n), so it still needs an element type
- let (nvec, _) = splitAppTy (Var.varType vec)
+ let (nvec, _) = Type.splitAppTy (Var.varType vec)
-- Put the type of the start value in nvec, this will be the type of our
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
genConcat' (Left res) f args@[arg] = do {
-- Setup the generate scheme
; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
- ; let (_, nvec) = splitAppTy (Var.varType arg)
+ ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
-- TODO: Use something better than varToString
; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
builder dst f args
else
error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> return $ trace ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f)) []
+ Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
IdInfo.ClassOpId cls -> do
-- FIXME: Not looking for what instance this class op is called for
-- Is quite stupid of course.
projects / matthijs / master-project / cλash.git / commitdiff