module CLasH.Translator
- ( makeVHDLStrings
- , makeVHDLAnnotations
+ ( -- makeVHDLStrings
+ makeVHDLAnnotations
) where
-- Standard Modules
import Text.PrettyPrint.HughesPJ (render)
import Data.Accessor
import qualified Data.Map as Map
+import Debug.Trace
-- GHC API
import qualified CoreSyn
-- | 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
- -> IO ()
-makeVHDLStrings libdir filenames topentity initstate testinput = do
- makeVHDL libdir filenames finder
- where
- finder = findSpec (hasVarName topentity)
- (hasVarName initstate)
- (hasVarName testinput)
+-- makeVHDLStrings ::
+-- FilePath -- ^ The GHC Library Dir
+-- -> [FilePath] -- ^ The FileNames
+-- -> String -- ^ The TopEntity
+-- -> String -- ^ The InitState
+-- -> String -- ^ The TestInput
+-- -> IO ()
+-- makeVHDLStrings libdir filenames topentity initstate testinput = do
+-- makeVHDL libdir filenames finder
+-- where
+-- finder = findSpec (hasVarName topentity)
+-- (hasVarName initstate)
+-- (isCLasHAnnotation isInitState)
+-- (hasVarName testinput)
-- | Turn Haskell to VHDL, Using the Annotations for Top Entity, Initial State
-- and Test Inputs found in the Files.
where
finder = findSpec (hasCLasHAnnotation isTopEntity)
(hasCLasHAnnotation isInitState)
+ (isCLasHAnnotation isInitState)
(hasCLasHAnnotation isTestInput)
-- | Turn Haskell to VHDL, using the given finder functions to find the Top
vhdl <- runTranslatorSession env $ do
let all_bindings = concat (map (\x -> CoreSyn.flattenBinds (HscTypes.cm_binds x)) cores)
-- Store the bindings we loaded
- tsBindings %= Map.fromList all_bindings
+ tsBindings %= Map.fromList all_bindings
+ let all_initstates = concat (map (\x -> case x of (_, Nothing, _) -> []; (_, Just inits, _) -> inits) specs)
+ tsInitStates %= Map.fromList all_initstates
test_binds <- catMaybesM $ Monad.mapM mkTest specs
+ mapM_ printAnns specs
let topbinds = Maybe.catMaybes $ map (\(top, _, _) -> top) specs
case topbinds of
[] -> error $ "Could not find top entity requested"
mkTest (Just top, _, Just input) = do
bndr <- createTestbench Nothing cores input top
return $ Just bndr
+ printAnns :: EntitySpec -> TranslatorSession ()
+ printAnns (_, Nothing, _) = trace ("no anns found:\n\n") $ return ()
+ printAnns (_, (Just anns), _) = trace ("anns:\n\n" ++ show anns ++ "\n") $ return ()
-- Run the given translator session. Generates a new UniqSupply for that
-- session.
-- a unique supply anywhere.
uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
let init_typestate = TypeState Map.empty [] Map.empty Map.empty env
- let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty
+ let init_state = TranslatorState uniqSupply init_typestate Map.empty Map.empty 0 Map.empty Map.empty Map.empty
return $ State.evalState session init_state
-- | Prepares the directory for writing VHDL files. This means creating the
import Language.Haskell.TH
import Data.Data
-data CLasHAnn = TopEntity | InitState | TestInput | TestCycles
+data CLasHAnn = TopEntity | InitState Name | TestInput | TestCycles
deriving (Show, Data, Typeable)
isTopEntity :: CLasHAnn -> Bool
isTopEntity _ = False
isInitState :: CLasHAnn -> Bool
-isInitState InitState = True
-isInitState _ = False
+isInitState (InitState _) = True
+isInitState _ = False
isTestInput :: CLasHAnn -> Bool
isTestInput TestInput = True
-- Local imports
import CLasH.VHDL.VHDLTypes
+import CLasH.Translator.Annotations
-- | A specification of an entity we can generate VHDL for. Consists of the
-- binder of the top level entity, an optional initial state and an optional
-- test input.
-type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreExpr, Maybe CoreSyn.CoreExpr)
+type EntitySpec = (Maybe CoreSyn.CoreBndr, Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)], Maybe CoreSyn.CoreExpr)
-- | A function that knows which parts of a module to compile
type Finder =
, tsEntityCounter_ :: Integer
, tsEntities_ :: Map.Map CoreSyn.CoreBndr Entity
, tsArchitectures_ :: Map.Map CoreSyn.CoreBndr (Architecture, [CoreSyn.CoreBndr])
+ , tsInitStates_ :: Map.Map CoreSyn.CoreBndr CoreSyn.CoreBndr
}
-- Derive accessors
-- Standard modules
import qualified Monad
import qualified System.IO.Unsafe
+import qualified Language.Haskell.TH as TH
+import qualified Maybe
-- GHC API
import qualified Annotations
Just f -> concatM $ mapM f cores
return (cores, env, specs)
+findBinds ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreBndr])
+findBinds criteria core = do
+ binders <- findBinder criteria core
+ case binders of
+ [] -> return Nothing
+ bndrs -> return $ Just $ map fst bndrs
+
findBind ::
Monad m =>
(Var.Var -> m Bool)
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreBndr)
findBind criteria core = do
+ binders <- findBinds criteria core
+ case binders of
+ Nothing -> return Nothing
+ (Just bndrs) -> return $ Just $ head bndrs
+
+findExprs ::
+ Monad m =>
+ (Var.Var -> m Bool)
+ -> HscTypes.CoreModule
+ -> m (Maybe [CoreSyn.CoreExpr])
+findExprs criteria core = do
binders <- findBinder criteria core
case binders of
[] -> return Nothing
- bndrs -> return $ Just $ fst $ head bndrs
+ bndrs -> return $ Just $ (map snd bndrs)
findExpr ::
Monad m =>
-> HscTypes.CoreModule
-> m (Maybe CoreSyn.CoreExpr)
findExpr criteria core = do
- binders <- findBinder criteria core
- case binders of
- [] -> return Nothing
- bndrs -> return $ Just $ snd $ head bndrs
+ exprs <- findExprs criteria core
+ case exprs of
+ Nothing -> return Nothing
+ (Just exprs) -> return $ Just $ head exprs
+
+findAnns ::
+ Monad m =>
+ (Var.Var -> m [CLasHAnn])
+ -> HscTypes.CoreModule
+ -> m [CLasHAnn]
+findAnns criteria core = do
+ let binds = CoreSyn.flattenBinds $ HscTypes.cm_binds core
+ anns <- Monad.mapM (criteria . fst) binds
+ case anns of
+ [] -> return []
+ xs -> return $ concat xs
-- | Find a binder in module according to a certain criteria
findBinder ::
return critbinds
-- | Determine if a binder has an Annotation meeting a certain criteria
-hasCLasHAnnotation ::
+isCLasHAnnotation ::
GHC.GhcMonad m =>
(CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
-> Var.Var -- ^ The Binder
- -> m Bool -- ^ Indicates if binder has the Annotation
-hasCLasHAnnotation clashAnn var = do
+ -> m [CLasHAnn] -- ^ Indicates if binder has the Annotation
+isCLasHAnnotation clashAnn var = do
let deserializer = Serialized.deserializeWithData
let target = Annotations.NamedTarget (Var.varName var)
(anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
let annEnts = filter clashAnn anns
- case annEnts of
+ return annEnts
+
+-- | Determine if a binder has an Annotation meeting a certain criteria
+hasCLasHAnnotation ::
+ GHC.GhcMonad m =>
+ (CLasHAnn -> Bool) -- ^ The criteria the Annotation has to meet
+ -> Var.Var -- ^ The Binder
+ -> m Bool -- ^ Indicates if binder has the Annotation
+hasCLasHAnnotation clashAnn var = do
+ anns <- isCLasHAnnotation clashAnn var
+ case anns of
[] -> return False
xs -> return True
-> m Bool -- ^ Indicate if the binder has the name
hasVarName lookfor bind = return $ lookfor == (Name.occNameString $ Name.nameOccName $ Name.getName bind)
+
+findInitStates ::
+ (Var.Var -> GHC.Ghc Bool) ->
+ (Var.Var -> GHC.Ghc [CLasHAnn]) ->
+ HscTypes.CoreModule ->
+ GHC.Ghc (Maybe [(CoreSyn.CoreBndr, CoreSyn.CoreBndr)])
+findInitStates statec annsc mod = do
+ states <- findBinds statec mod
+ anns <- findAnns annsc mod
+ let funs = Maybe.catMaybes (map extractInits anns)
+ exprs' <- mapM (\x -> findBind (hasVarName (TH.nameBase x)) mod) funs
+ let exprs = Maybe.catMaybes exprs'
+ let inits = zipMWith (\a b -> (a,b)) states exprs
+ return inits
+ where
+ extractInits :: CLasHAnn -> Maybe TH.Name
+ extractInits (InitState x) = Just x
+ extractInits _ = Nothing
+ zipMWith :: (a -> b -> c) -> (Maybe [a]) -> [b] -> (Maybe [c])
+ zipMwith _ Nothing _ = Nothing
+ zipMWith f (Just as) bs = Just $ zipWith f as bs
+
-- | Make a complete spec out of a three conditions
findSpec ::
- (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool)
+ (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc Bool) -> (Var.Var -> GHC.Ghc [CLasHAnn]) -> (Var.Var -> GHC.Ghc Bool)
-> Finder
-findSpec topc statec testc mod = do
+findSpec topc statec annsc testc mod = do
top <- findBind topc mod
- state <- findExpr statec mod
+ state <- findExprs statec mod
+ anns <- findAnns annsc mod
test <- findExpr testc mod
- return [(top, state, test)]
+ inits <- findInitStates statec annsc mod
+ return [(top, inits, test)]
-- case top of
-- Just t -> return [(t, state, test)]
-- Nothing -> return error $ "Could not find top entity requested"
(state_vars, sms) <- Monad.mapAndUnzipM dobind binds
let (in_state_maybes, out_state_maybes) = unzip state_vars
let (statementss, used_entitiess) = unzip sms
+ -- Get initial state, if it's there
+ initSmap <- getA tsInitStates
+ let init_state = Map.lookup fname initSmap
-- Create a state proc, if needed
- state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
- ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
- ([], []) -> return []
- (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
+ (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
+ ([in_state], [out_state], Nothing) -> error $ "No initial state defined for: " ++ show fname
+ ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
+ ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
+ ([], [], Nothing) -> return ([],[])
+ (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
-- Join the create statements and the (optional) state_proc
let statements = concat statementss ++ state_proc
-- Create the architecture
let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
- let used_entities = concat used_entitiess
+ let used_entities = (concat used_entitiess) ++ resbndr
return (arch, used_entities)
where
dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
return ((Nothing, Nothing), sms)
mkStateProcSm ::
- (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
- -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
-mkStateProcSm (old, new) = do
- nonempty <- hasNonEmptyType old
+ (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
+ -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
+mkStateProcSm (old, new, res) = do
+ nonempty <- hasNonEmptyType old
if nonempty
- then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
- else return []
- where
- label = mkVHDLBasicId $ "state"
- rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
- wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
- clk_assign = AST.SigAssign (varToVHDLName old) wform
- rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
- resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
- reset_statement = []
- clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
- statement = AST.IfSm resetn_is_low reset_statement clk_statement Nothing
-
+ then do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
+ type_mark_old_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType old)
+ let type_mark_old = Maybe.fromJust type_mark_old_maybe
+ type_mark_res_maybe <- MonadState.lift tsType $ vhdl_ty error_msg (Var.varType res)
+ let type_mark_res' = Maybe.fromJust type_mark_res_maybe
+ let type_mark_res = if type_mark_old == type_mark_res' then
+ type_mark_res'
+ else
+ error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
+ let resvalid = mkVHDLBasicId $ varToString res ++ "val"
+ let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
+ let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
+ let res_assign = AST.SigAssign (varToVHDLName old) reswform
+ let blocklabel = mkVHDLBasicId $ "state"
+ let statelabel = mkVHDLBasicId $ "stateupdate"
+ let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
+ let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
+ let clk_assign = AST.SigAssign (varToVHDLName old) wform
+ let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
+ let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
+ signature <- getEntity res
+ let entity_id = ent_id signature
+ let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
+ let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
+ let reset_statement = mkComponentInst reslabel entity_id portmaps
+ let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
+ let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
+ let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId] [statement]
+ let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
+ return ([block],[res])
+ else
+ return ([],[])
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
-- Throw away all empty members
case Maybe.catMaybes elem_tys' of
[] -> -- No non-empty members
- return $ Right Nothing
+ return $ Right Nothing
elem_tys -> do
let elems = zipWith AST.ElementDec recordlabels elem_tys
-- For a single construct datatype, build a record with one field for
projects / matthijs / master-project / cλash.git / commitdiff