From: Christiaan Baaij Date: Fri, 6 Nov 2009 12:12:00 +0000 (+0100) Subject: Start support on initial state. Substates currently break X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=a54863feb7304aa6a843efc15d29f017c45407f4;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Start support on initial state. Substates currently break --- diff --git "a/c\316\273ash/CLasH/Translator.hs" "b/c\316\273ash/CLasH/Translator.hs" index 6528f54..e2993d2 100644 --- "a/c\316\273ash/CLasH/Translator.hs" +++ "b/c\316\273ash/CLasH/Translator.hs" @@ -1,6 +1,6 @@ module CLasH.Translator - ( makeVHDLStrings - , makeVHDLAnnotations + ( -- makeVHDLStrings + makeVHDLAnnotations ) where -- Standard Modules @@ -12,6 +12,7 @@ import qualified Control.Monad.Trans.State as State import Text.PrettyPrint.HughesPJ (render) import Data.Accessor import qualified Data.Map as Map +import Debug.Trace -- GHC API import qualified CoreSyn @@ -36,19 +37,20 @@ import CLasH.VHDL.Testbench -- | 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. @@ -61,6 +63,7 @@ makeVHDLAnnotations libdir filenames = do where finder = findSpec (hasCLasHAnnotation isTopEntity) (hasCLasHAnnotation isInitState) + (isCLasHAnnotation isInitState) (hasCLasHAnnotation isTestInput) -- | Turn Haskell to VHDL, using the given finder functions to find the Top @@ -92,8 +95,11 @@ moduleToVHDL env cores specs = do 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" @@ -108,6 +114,9 @@ moduleToVHDL env cores specs = do 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. @@ -120,7 +129,7 @@ runTranslatorSession env session = do -- 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 diff --git "a/c\316\273ash/CLasH/Translator/Annotations.hs" "b/c\316\273ash/CLasH/Translator/Annotations.hs" index ff2bb4b..6176438 100644 --- "a/c\316\273ash/CLasH/Translator/Annotations.hs" +++ "b/c\316\273ash/CLasH/Translator/Annotations.hs" @@ -4,7 +4,7 @@ module CLasH.Translator.Annotations where 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 @@ -12,8 +12,8 @@ isTopEntity TopEntity = True isTopEntity _ = False isInitState :: CLasHAnn -> Bool -isInitState InitState = True -isInitState _ = False +isInitState (InitState _) = True +isInitState _ = False isTestInput :: CLasHAnn -> Bool isTestInput TestInput = True diff --git "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" index ee2220d..12ca6ed 100644 --- "a/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" +++ "b/c\316\273ash/CLasH/Translator/TranslatorTypes.hs" @@ -23,11 +23,12 @@ import qualified Language.VHDL.AST as AST -- 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 = @@ -90,6 +91,7 @@ data TranslatorState = TranslatorState { , 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 diff --git "a/c\316\273ash/CLasH/Utils/GhcTools.hs" "b/c\316\273ash/CLasH/Utils/GhcTools.hs" index 6e9a6dc..373e9cf 100644 --- "a/c\316\273ash/CLasH/Utils/GhcTools.hs" +++ "b/c\316\273ash/CLasH/Utils/GhcTools.hs" @@ -5,6 +5,8 @@ module CLasH.Utils.GhcTools where -- 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 @@ -96,16 +98,38 @@ loadModules libdir filenames finder = 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 => @@ -113,10 +137,22 @@ findExpr :: -> 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 :: @@ -130,17 +166,27 @@ findBinder criteria core = do 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 @@ -152,16 +198,40 @@ hasVarName :: -> 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" diff --git "a/c\316\273ash/CLasH/VHDL/Generate.hs" "b/c\316\273ash/CLasH/VHDL/Generate.hs" index 37caa45..7c604d6 100644 --- "a/c\316\273ash/CLasH/VHDL/Generate.hs" +++ "b/c\316\273ash/CLasH/VHDL/Generate.hs" @@ -129,16 +129,21 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do (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 @@ -162,24 +167,44 @@ getArchitecture fname = Utils.makeCached fname tsArchitectures $ do 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 :: diff --git "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" index edca0c3..1378376 100644 --- "a/c\316\273ash/CLasH/VHDL/VHDLTools.hs" +++ "b/c\316\273ash/CLasH/VHDL/VHDLTools.hs" @@ -402,7 +402,7 @@ mk_tycon_ty ty tycon args = -- 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