import qualified Data.Monoid as Monoid
import Data.Accessor
import qualified Data.Accessor.MonadState as MonadState
+import Text.Regex.Posix
-- ForSyDe
import qualified ForSyDe.Backend.VHDL.AST as AST
import TranslatorTypes
import HsValueMap
import Pretty
+import CoreTools
createDesignFiles ::
FlatFuncMap
-> [(AST.VHDLId, AST.DesignFile)]
createDesignFiles flatfuncmap =
- (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) :
+ (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
map (Arrow.second $ AST.DesignFile full_context) units
where
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
+ AST.Library $ mkVHDLBasicId "IEEE",
+ mkUseAll ["IEEE", "std_logic_1164"],
+ mkUseAll ["IEEE", "numeric_std"]
]
full_context =
- (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All)
+ mkUseAll ["work", "types"]
: ieee_context
- type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
+ type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
+-- Create a use foo.bar.all statement. Takes a list of components in the used
+-- name. Must contain at least two components
+mkUseAll :: [String] -> AST.ContextItem
+mkUseAll ss =
+ AST.Use $ from AST.:.: AST.All
+ where
+ base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
+ from = foldl select base_prefix (tail ss)
+ select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
+
createLibraryUnits ::
FlatFuncMap
-> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
if isPortSigUse $ sigUse info
then do
type_mark <- vhdl_ty ty
- return $ Just (mkVHDLId nm, type_mark)
+ return $ Just (mkVHDLExtId nm, type_mark)
else
return $ Nothing
)
-- Add a clk port if we have state
clk_port = if hasState hsfunc
then
- [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
+ [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
else
[]
-- | Generate a VHDL entity name for the given hsfunc
mkEntityId hsfunc =
-- TODO: This doesn't work for functions with multiple signatures!
- mkVHDLId $ hsFuncName hsfunc
+ -- Use a Basic Id, since using extended id's for entities throws off
+ -- precision and causes problems when generating filenames.
+ mkVHDLBasicId $ hsFuncName hsfunc
-- | Create an architecture for a given function
createArchitecture ::
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')
+ statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
+ return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
where
sigs = flat_sigs flatfunc
args = flat_args flatfunc
mkStateProcSm (num, old, new) =
AST.ProcSm label [clk] [statement]
where
- label = mkVHDLId $ "state_" ++ (show num)
- clk = mkVHDLId "clk"
- rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
+ label = mkVHDLExtId $ "state_" ++ (show num)
+ clk = mkVHDLExtId "clk"
+ rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
-- is not named.
getSignalId :: SignalInfo -> AST.VHDLId
getSignalId info =
- mkVHDLId $ Maybe.fromMaybe
+ mkVHDLExtId $ Maybe.fromMaybe
(error $ "Unnamed signal? This should not happen!")
(sigName info)
-- | Transforms a signal definition into a VHDL concurrent statement
mkConcSm ::
- SignatureMap -- ^ The interfaces of functions in the session
- -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
+ [(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.
+ -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
-mkConcSm signatures sigs (FApp hsfunc args res) num =
+mkConcSm sigs (FApp hsfunc args res) num = do
+ signatures <- getA vsSignatures
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
+ 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 $ mkVHDLExtId "clk") "clk"
+ portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
+ in
+ return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
+
+mkConcSm sigs (UncondDef src dst) _ = do
+ 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
where
- vhdl_expr (Left id) = mkIdExpr sigs id
+ vhdl_expr (Left id) = return $ mkIdExpr sigs id
vhdl_expr (Right expr) =
case expr of
(EqLit id lit) ->
- (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
- (Literal lit) ->
- AST.PrimLit lit
+ return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
+ (Literal lit Nothing) ->
+ return $ AST.PrimLit lit
+ (Literal lit (Just ty)) -> do
+ -- Create a cast expression, which is just a function call using the
+ -- type name as the function name.
+ let litexpr = AST.PrimLit lit
+ ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
+ let ty_name = AST.NSimple ty_id
+ let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
+ return $ AST.PrimFCall $ AST.FCall ty_name args
(Eq a b) ->
- (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
+ return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
-mkConcSm _ sigs (CondDef cond true false dst) _ =
+mkConcSm sigs (CondDef cond true false dst) _ =
let
cond_expr = mkIdExpr sigs cond
true_expr = mkIdExpr sigs true
dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
in
- AST.CSSASm assign
+ return $ AST.CSSASm assign
-- | Turn a SignalId into a VHDL Expr
mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
-- | Create an VHDL port -> signal association
mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
-mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
+mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
mkAssocElem Nothing _ = Nothing
-- | The VHDL Bit type
(tycon, args) <- Type.splitTyConApp_maybe ty
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
- "FSVec" -> Just $ mk_fsvec_ty ty args
+ "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
+ "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
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
+-- | Create a VHDL vector type
+mk_vector_ty ::
+ Int -- ^ The length of the vector
+ -> Type.Type -- ^ The Haskell type to create a VHDL type for
-> 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))
+mk_vector_ty len ty = do
+ -- Assume there is a single type argument
+ let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
-- TODO: Use el_ty
- let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
+ let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
let ty_dec = AST.TypeDec ty_id ty_def
-- TODO: Check name uniqueness
("Bool", bool_ty) -- TysWiredIn.boolTy
]
--- Shortcut
-mkVHDLId :: String -> AST.VHDLId
-mkVHDLId s =
- AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
+-- Shortcut for
+-- Can only contain alphanumerics and underscores. The supplied string must be
+-- a valid basic id, otherwise an error value is returned. This function is
+-- not meant to be passed identifiers from a source file, use mkVHDLExtId for
+-- that.
+mkVHDLBasicId :: String -> AST.VHDLId
+mkVHDLBasicId s =
+ AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
where
-- Strip invalid characters.
strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
+ -- Strip leading numbers and underscores
+ strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
-- Strip multiple adjacent underscores
strip_multiscore = concat . map (\cs ->
case cs of
_ -> cs
) . List.group
+-- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
+-- different characters than basic ids, but can never be used to refer to
+-- basic ids.
+-- Use extended Ids for any values that are taken from the source file.
+mkVHDLExtId :: String -> AST.VHDLId
+mkVHDLExtId s =
+ AST.unsafeVHDLExtId $ strip_invalid s
+ where
+ -- Allowed characters, taken from ForSyde's mkVHDLExtId
+ allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
+ strip_invalid = filter (`elem` allowed)
+
-- | 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
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))
+ Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
)
builtin_hsfuncs = Map.keys builtin_funcs
-- | 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))
-
--- vim: set ts=8 sw=2 sts=2 expandtab:
+toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))