X-Git-Url: https://git.stderr.nl/gitweb?a=blobdiff_plain;f=VHDL.hs;h=572e221b4abb120e94d4871489e5f94b92f1be81;hb=2fc713015ccdabfb4f979546c3ecd0dd40329bb8;hp=d9dce9e699f9188dfefc9726f625a7369bc7cd29;hpb=bf0b6fedf46d525cc7e4d389b4fb7dd539174939;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git diff --git a/VHDL.hs b/VHDL.hs index d9dce9e..572e221 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -5,11 +5,15 @@ module VHDL where import qualified Data.Foldable as Foldable import qualified Data.List as List +import qualified Data.Map as Map import qualified Maybe import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow +import qualified Control.Monad.Trans.State as State import qualified Data.Traversable as Traversable import qualified Data.Monoid as Monoid +import Data.Accessor +import qualified Data.Accessor.MonadState as MonadState import qualified Type import qualified TysWiredIn @@ -23,59 +27,72 @@ import VHDLTypes import Flatten import FlattenTypes import TranslatorTypes +import HsValueMap import Pretty -getDesignFiles :: [FuncData] -> [AST.DesignFile] -getDesignFiles funcs = - map (AST.DesignFile context) units - where - units = filter (not.null) $ map getLibraryUnits funcs - context = [ - AST.Library $ mkVHDLId "IEEE", - AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All] +createDesignFiles :: + FlatFuncMap + -> [(AST.VHDLId, AST.DesignFile)] + +createDesignFiles flatfuncmap = + (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) : + map (Arrow.second $ AST.DesignFile full_context) units + where + init_session = VHDLSession Map.empty builtin_funcs + (units, final_session) = + State.runState (createLibraryUnits flatfuncmap) init_session + ty_decls = Map.elems (final_session ^. vsTypes) + ieee_context = [ + AST.Library $ mkVHDLId "IEEE", + AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All + ] + full_context = + (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All) + : ieee_context + type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls) + +createLibraryUnits :: + FlatFuncMap + -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])] + +createLibraryUnits flatfuncmap = do + let hsfuncs = Map.keys flatfuncmap + let flatfuncs = Map.elems flatfuncmap + entities <- Monad.zipWithM createEntity hsfuncs flatfuncs + archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs + return $ zipWith + (\ent arch -> + let AST.EntityDec id _ = ent in + (id, [AST.LUEntity ent, AST.LUArch arch]) + ) + entities archs + -- | Create an entity for a given function createEntity :: - HsFunction -- | The function signature - -> FuncData -- | The function data collected so far - -> VHDLState () - -createEntity hsfunc fdata = - let func = flatFunc fdata in - case func of - -- Skip (builtin) functions without a FlatFunction - Nothing -> do return () - -- Create an entity for all other functions - Just flatfunc -> - let - sigs = flat_sigs flatfunc - args = flat_args flatfunc - res = flat_res flatfunc - (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args - (ty_decls', res') = Traversable.traverse (mkMap sigs) res - -- TODO: Unique ty_decls - ent_decl' = createEntityAST hsfunc args' res' - pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types" - pkg_decl = if null ty_decls && null ty_decls' - then Nothing - else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls') - AST.EntityDec entity_id _ = ent_decl' - entity' = Entity entity_id args' res' (Just ent_decl') pkg_decl - in do - setEntity hsfunc entity' + HsFunction -- | The function signature + -> FlatFunction -- | The FlatFunction + -> VHDLState AST.EntityDec -- | The resulting entity + +createEntity hsfunc flatfunc = do + let sigs = flat_sigs flatfunc + let args = flat_args flatfunc + let res = flat_res flatfunc + args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args + res' <- Traversable.traverse (mkMap sigs) res + let ent_decl' = createEntityAST hsfunc args' res' + let AST.EntityDec entity_id _ = ent_decl' + let signature = Entity entity_id args' res' + modA vsSignatures (Map.insert hsfunc signature) + return ent_decl' where mkMap :: [(SignalId, SignalInfo)] -> SignalId - -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark)) - mkMap sigmap id = - if isPortSigUse $ sigUse info - then - let (decs, type_mark) = vhdl_ty ty in - (decs, Just (mkVHDLId nm, type_mark)) - else - (Monoid.mempty, Nothing) - where + -> VHDLState VHDLSignalMapElement + -- We only need the vsTypes element from the state + mkMap sigmap = MonadState.lift vsTypes . (\id -> + let info = Maybe.fromMaybe (error $ "Signal not found in the name map? This should not happen!") (lookup id sigmap) @@ -83,6 +100,14 @@ createEntity hsfunc fdata = (error $ "Signal not named? This should not happen!") (sigName info) ty = sigTy info + in + if isPortSigUse $ sigUse info + then do + type_mark <- vhdl_ty ty + return $ Just (mkVHDLId nm, type_mark) + else + return $ Nothing + ) -- | Create the VHDL AST for an entity createEntityAST :: @@ -124,35 +149,31 @@ mkEntityId hsfunc = -- | Create an architecture for a given function createArchitecture :: - HsFunction -- | The function signature - -> FuncData -- | The function data collected so far - -> VHDLState () - -createArchitecture hsfunc fdata = - let func = flatFunc fdata in - case func of - -- Skip (builtin) functions without a FlatFunction - Nothing -> do return () - -- Create an architecture for all other functions - Just flatfunc -> do - let sigs = flat_sigs flatfunc - let args = flat_args flatfunc - let res = flat_res flatfunc - let defs = flat_defs flatfunc - let entity_id = Maybe.fromMaybe - (error $ "Building architecture without an entity? This should not happen!") - (getEntityId fdata) - -- Create signal declarations for all signals that are not in args and - -- res - let (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs - -- TODO: Unique ty_decls - -- TODO: Store ty_decls somewhere - -- Create concurrent statements for all signal definitions - statements <- mapM (mkConcSm sigs) defs - let procs = map mkStateProcSm (makeStatePairs flatfunc) - let procs' = map AST.CSPSm procs - let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') - setArchitecture hsfunc arch + HsFunction -- ^ The function signature + -> FlatFunction -- ^ The FlatFunction + -> VHDLState AST.ArchBody -- ^ The architecture for this function + +createArchitecture hsfunc flatfunc = do + signaturemap <- getA vsSignatures + let signature = Maybe.fromMaybe + (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!") + (Map.lookup hsfunc signaturemap) + let entity_id = ent_id signature + -- Create signal declarations for all internal and state signals + sig_dec_maybes <- mapM (mkSigDec' . snd) sigs + let sig_decs = Maybe.catMaybes $ sig_dec_maybes + -- Create concurrent statements for all signal definitions + let statements = zipWith (mkConcSm signaturemap sigs) defs [0..] + return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs') + where + sigs = flat_sigs flatfunc + args = flat_args flatfunc + res = flat_res flatfunc + defs = flat_defs flatfunc + procs = map mkStateProcSm (makeStatePairs flatfunc) + procs' = map AST.CSPSm procs + -- mkSigDec only uses vsTypes from the state + mkSigDec' = MonadState.lift vsTypes . mkSigDec -- | Looks up all pairs of old state, new state signals, together with -- the state id they represent. @@ -181,14 +202,14 @@ mkStateProcSm (num, old, new) = rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)] statement = AST.IfSm rising_edge_clk [assign] [] Nothing -mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec) +mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec) mkSigDec info = let use = sigUse info in - if isInternalSigUse use || isStateSigUse use then - let (ty_decls, type_mark) = vhdl_ty ty in - (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing) + if isInternalSigUse use || isStateSigUse use then do + type_mark <- vhdl_ty ty + return $ Just (AST.SigDec (getSignalId info) type_mark Nothing) else - ([], Nothing) + return Nothing where ty = sigTy info @@ -202,31 +223,34 @@ getSignalId info = -- | Transforms a signal definition into a VHDL concurrent statement mkConcSm :: - [(SignalId, SignalInfo)] -- | The signals in the current architecture - -> SigDef -- | The signal definition - -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation. - -mkConcSm sigs (FApp hsfunc args res) = do - fdata_maybe <- getFunc hsfunc - let fdata = Maybe.fromMaybe - (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!") - fdata_maybe - let entity = Maybe.fromMaybe - (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!") - (funcEntity fdata) - let entity_id = ent_id entity - label <- uniqueName (AST.fromVHDLId entity_id) - -- Add a clk port if we have state - let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk" - let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else []) - return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) - -mkConcSm sigs (UncondDef src dst) = do - let src_expr = vhdl_expr src - let src_wform = AST.Wform [AST.WformElem src_expr Nothing] - let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst) - let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) - return $ AST.CSSASm assign + SignatureMap -- ^ The interfaces of functions in the session + -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture + -> SigDef -- ^ The signal definition + -> Int -- ^ A number that will be unique for all + -- concurrent statements in the architecture. + -> AST.ConcSm -- ^ The corresponding VHDL component instantiation. + +mkConcSm signatures sigs (FApp hsfunc args res) num = + let + signature = Maybe.fromMaybe + (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!") + (Map.lookup hsfunc signatures) + entity_id = ent_id signature + label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num) + -- Add a clk port if we have state + clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk" + portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else []) + in + AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps) + +mkConcSm _ sigs (UncondDef src dst) _ = + let + src_expr = vhdl_expr src + src_wform = AST.Wform [AST.WformElem src_expr Nothing] + dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst) + assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing) + in + AST.CSSASm assign where vhdl_expr (Left id) = mkIdExpr sigs id vhdl_expr (Right expr) = @@ -238,16 +262,18 @@ mkConcSm sigs (UncondDef src dst) = do (Eq a b) -> (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b) -mkConcSm sigs (CondDef cond true false dst) = do - let cond_expr = mkIdExpr sigs cond - let true_expr = mkIdExpr sigs true - let false_expr = mkIdExpr sigs false - let false_wform = AST.Wform [AST.WformElem false_expr Nothing] - let true_wform = AST.Wform [AST.WformElem true_expr Nothing] - let whenelse = AST.WhenElse true_wform cond_expr - let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst) - let assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing) - return $ AST.CSSASm assign +mkConcSm _ sigs (CondDef cond true false dst) _ = + let + cond_expr = mkIdExpr sigs cond + true_expr = mkIdExpr sigs true + false_expr = mkIdExpr sigs false + false_wform = AST.Wform [AST.WformElem false_expr Nothing] + true_wform = AST.Wform [AST.WformElem true_expr Nothing] + whenelse = AST.WhenElse true_wform cond_expr + dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst) + assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing) + in + AST.CSSASm assign -- | Turn a SignalId into a VHDL Expr mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr @@ -294,32 +320,6 @@ mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal))) mkAssocElem Nothing _ = Nothing --- | Extracts the generated entity id from the given funcdata -getEntityId :: FuncData -> Maybe AST.VHDLId -getEntityId fdata = - case funcEntity fdata of - Nothing -> Nothing - Just e -> case ent_decl e of - Nothing -> Nothing - Just (AST.EntityDec id _) -> Just id - -getLibraryUnits :: - FuncData -- | A function from the session - -> [AST.LibraryUnit] -- | The entity, architecture and optional package for the function - -getLibraryUnits fdata = - case funcEntity fdata of - Nothing -> [] - Just ent -> - case ent_decl ent of - Nothing -> [] - Just decl -> - case funcArch fdata of - Nothing -> [] - Just arch -> - [AST.LUEntity decl, AST.LUArch arch] - ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent)) - -- | The VHDL Bit type bit_ty :: AST.TypeMark bit_ty = AST.unsafeVHDLBasicId "Bit" @@ -333,38 +333,57 @@ std_logic_ty :: AST.TypeMark std_logic_ty = AST.unsafeVHDLBasicId "std_logic" -- Translate a Haskell type to a VHDL type -vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark) -vhdl_ty ty = Maybe.fromMaybe - (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)) - (vhdl_ty_maybe ty) - --- Translate a Haskell type to a VHDL type, optionally generating a type --- declaration for the type. -vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark) -vhdl_ty_maybe ty = - if Type.coreEqType ty TysWiredIn.boolTy - then - Just ([], bool_ty) - else - case Type.splitTyConApp_maybe ty of - Just (tycon, args) -> - let name = TyCon.tyConName tycon in - -- TODO: Do something more robust than string matching - case Name.getOccString name of - "Bit" -> Just ([], std_logic_ty) - "FSVec" -> - let - [len, el_ty] = args - -- TODO: Find actual number - ty_id = mkVHDLId ("vector_" ++ (show len)) - -- TODO: Use el_ty - range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")] - ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty - ty_dec = AST.TypeDec ty_id ty_def - in - Just ([ty_dec], ty_id) - otherwise -> Nothing - otherwise -> Nothing +vhdl_ty :: Type.Type -> TypeState AST.TypeMark +vhdl_ty ty = do + typemap <- State.get + let builtin_ty = do -- See if this is a tycon and lookup its name + (tycon, args) <- Type.splitTyConApp_maybe ty + let name = Name.getOccString (TyCon.tyConName tycon) + Map.lookup name builtin_types + -- If not a builtin type, try the custom types + let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap + case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of + -- Found a type, return it + Just t -> return t + -- No type yet, try to construct it + Nothing -> do + let new_ty = do + -- Use the Maybe Monad for failing when one of these fails + (tycon, args) <- Type.splitTyConApp_maybe ty + let name = Name.getOccString (TyCon.tyConName tycon) + case name of + "FSVec" -> Just $ mk_fsvec_ty ty args + otherwise -> Nothing + -- Return new_ty when a new type was successfully created + Maybe.fromMaybe + (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)) + new_ty + +-- | Create a VHDL type belonging to a FSVec Haskell type +mk_fsvec_ty :: + Type.Type -- ^ The Haskell type to create a VHDL type for + -> [Type.Type] -- ^ Type arguments to the FSVec type constructor + -> TypeState AST.TypeMark -- The typemark created. + +mk_fsvec_ty ty args = do + -- Assume there are two type arguments + let [len, el_ty] = args + -- TODO: Find actual number + -- Construct the type id, but filter out dots (since these are not allowed). + let ty_id = mkVHDLId $ filter (/='.') ("vector_" ++ (show len)) + -- TODO: Use el_ty + let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")] + let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty + let ty_dec = AST.TypeDec ty_id ty_def + State.modify (Map.insert (OrdType ty) (ty_id, ty_dec)) + return ty_id + + +builtin_types = + Map.fromList [ + ("Bit", std_logic_ty), + ("Bool", bool_ty) -- TysWiredIn.boolTy + ] -- Shortcut mkVHDLId :: String -> AST.VHDLId @@ -379,3 +398,30 @@ mkVHDLId s = ('_':_) -> "_" _ -> cs ) . List.group + +-- | A consise representation of a (set of) ports on a builtin function +type PortMap = HsValueMap (String, AST.TypeMark) +-- | A consise representation of a builtin function +data BuiltIn = BuiltIn String [PortMap] PortMap + +-- | Translate a list of concise representation of builtin functions to a +-- SignatureMap +mkBuiltins :: [BuiltIn] -> SignatureMap +mkBuiltins = Map.fromList . map (\(BuiltIn name args res) -> + (HsFunction name (map useAsPort args) (useAsPort res), + Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res)) + ) + +builtin_hsfuncs = Map.keys builtin_funcs +builtin_funcs = mkBuiltins + [ + BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)), + BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)), + BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)), + BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)) + ] + +-- | 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 (mkVHDLId name, ty))