module VHDL where
-- Standard modules
-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 Text.Regex.Posix
-import Debug.Trace
-- ForSyDe
import qualified ForSyDe.Backend.VHDL.AST as AST
import CoreSyn
import qualified Type
import qualified Name
-import qualified OccName
import qualified Var
import qualified Id
import qualified IdInfo
import qualified TyCon
-import qualified TcType
import qualified DataCon
import qualified CoreSubst
import qualified CoreUtils
-- Local imports
import VHDLTypes
-import Flatten
-import FlattenTypes
-import TranslatorTypes
-import HsValueMap
+import VHDLTools
import Pretty
import CoreTools
import Constants
tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
+ tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
+ tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
+ tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
ieee_context = [
AST.Library $ mkVHDLBasicId "IEEE",
mkUseAll ["IEEE", "std_logic_1164"],
]
full_context =
mkUseAll ["work", "types"]
- : ieee_context
- type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (vec_decls ++ ty_decls ++ subProgSpecs)
+ : (mkUseAll ["work"]
+ : ieee_context)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
subProgSpecs = concat (map subProgSpec tyfun_decls)
subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
-- Add a clk port if we have state
clk_port = if True -- hasState hsfunc
then
- Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
+ Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logic_ty
else
Nothing
mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
mkIfaceSigDec _ Nothing = Nothing
+{-
-- | Generate a VHDL entity name for the given hsfunc
mkEntityId hsfunc =
-- TODO: This doesn't work for functions with multiple signatures!
-- 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 ::
let statements = concat statementss
return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
where
- procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
+ procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
procs' = map AST.CSPSm procs
-- mkSigDec only uses vsTypes from the state
mkSigDec' = mkSigDec
+{-
-- | Looks up all pairs of old state, new state signals, together with
-- the state id they represent.
makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
statement = AST.IfSm rising_edge_clk [assign] [] Nothing
+-- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
+-- is not named.
+getSignalId :: SignalInfo -> AST.VHDLId
+getSignalId info =
+ mkVHDLExtId $ Maybe.fromMaybe
+ (error $ "Unnamed signal? This should not happen!")
+ (sigName info)
+-}
+
mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
mkSigDec bndr =
if True then do --isInternalSigUse use || isStateSigUse use then do
else
return Nothing
--- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
--- is not named.
-getSignalId :: SignalInfo -> AST.VHDLId
-getSignalId info =
- mkVHDLExtId $ Maybe.fromMaybe
- (error $ "Unnamed signal? This should not happen!")
- (sigName info)
-
-- | Transforms a core binding into a VHDL concurrent statement
mkConcSm ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
-> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
+
+-- Ignore Cast expressions, they should not longer have any meaning as long as
+-- the type works out.
+mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
+
+-- For simple a = b assignments, just generate an unconditional signal
+-- assignment. This should only happen for dataconstructors without arguments.
+-- TODO: Integrate this with the below code for application (essentially this
+-- is an application without arguments)
+mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
+
mkConcSm (bndr, app@(CoreSyn.App _ _))= do
let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
let valargs' = filter isValArg args
-- It's a global value imported from elsewhere. These can be builtin
-- functions.
funSignatures <- getA vsNameTable
+ signatures <- getA vsSignatures
case (Map.lookup (bndrToString f) funSignatures) of
Just (arg_count, builder) ->
if length valargs == arg_count then
- let
- sigs = map (bndrToString.varBndr) valargs
- sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
- func = builder sigsNames
- src_wform = AST.Wform [AST.WformElem func Nothing]
- dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
- assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
- in
- return [AST.CSSASm assign]
+ case builder of
+ Left funBuilder ->
+ let
+ sigs = map (varToVHDLExpr.varBndr) valargs
+ func = funBuilder sigs
+ src_wform = AST.Wform [AST.WformElem func Nothing]
+ dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
+ assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
+ in
+ return [AST.CSSASm assign]
+ Right genBuilder ->
+ let
+ sigs = map varBndr valargs
+ signature = Maybe.fromMaybe
+ (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!")
+ (Map.lookup (head sigs) signatures)
+ arg = tail sigs
+ genSm = genBuilder signature (arg ++ [bndr])
+ in return [AST.CSGSm genSm]
else
error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
label = "comp_ins_" ++ bndrToString bndr
-- Add a clk port if we have state
--clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
+ clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
--portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
- portmaps = mkAssocElems args bndr signature
+ portmaps = clk_port : mkAssocElems args bndr signature
in
- return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)]
+ return [genComponentInst label entity_id portmaps]
details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
-- A single alt case must be a selector. This means thee scrutinee is a simple
-- first is the default case, if there is any.
mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
let
- cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
+ cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
true_expr = (varToVHDLExpr true)
false_expr = (varToVHDLExpr false)
in
mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
--- Create an unconditional assignment statement
-mkUncondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The expression to assign
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkUncondAssign dst expr = mkAssign dst Nothing expr
-
--- Create a conditional assignment statement
-mkCondAssign ::
- Either CoreBndr AST.VHDLName -- ^ The signal to assign to
- -> AST.Expr -- ^ The condition
- -> AST.Expr -- ^ The value when true
- -> AST.Expr -- ^ The value when false
- -> AST.ConcSm -- ^ The resulting concurrent statement
-mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
-
--- Create a conditional or unconditional assignment statement
-mkAssign ::
- Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
- Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
- -- and the value to assign when true.
- AST.Expr -> -- ^ The value to assign when false or no condition
- AST.ConcSm -- ^ The resulting concurrent statement
-
-mkAssign dst cond false_expr =
- let
- -- I'm not 100% how this assignment AST works, but this gets us what we
- -- want...
- whenelse = case cond of
- Just (cond_expr, true_expr) ->
- let
- true_wform = AST.Wform [AST.WformElem true_expr Nothing]
- in
- [AST.WhenElse true_wform cond_expr]
- Nothing -> []
- false_wform = AST.Wform [AST.WformElem false_expr Nothing]
- dst_name = case dst of
- Left bndr -> AST.NSimple (bndrToVHDLId bndr)
- Right name -> name
- assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
- in
- AST.CSSASm assign
-
--- Create a record field selector that selects the given label from the record
--- stored in the given binder.
-mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
-mkSelectedName bndr label =
- let
- sel_prefix = AST.NSimple $ bndrToVHDLId bndr
- sel_suffix = AST.SSimple $ label
- in
- AST.NSelected $ sel_prefix AST.:.: sel_suffix
-
-- Finds the field labels for VHDL type generated for the given Core type,
-- which must result in a record type.
getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
_ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
--- Turn a variable reference into a AST expression
-varToVHDLExpr :: Var.Var -> AST.Expr
-varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
-
--- Turn a constructor into an AST expression. For dataconstructors, this is
--- only the constructor itself, not any arguments it has. Should not be called
--- with a DEFAULT constructor.
-conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
-conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
- where
- tycon = DataCon.dataConTyCon dc
- tyname = TyCon.tyConName tycon
- dcname = DataCon.dataConName dc
- lit = case Name.getOccString tyname of
- -- TODO: Do something more robust than string matching
- "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
- "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
-conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
-conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
-
-
-
{-
mkConcSm sigs (UncondDef src dst) _ = do
src_expr <- vhdl_expr src
assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
in
return $ AST.CSSASm assign
--}
--- | Turn a SignalId into a VHDL Expr
+
+| Turn a SignalId into a VHDL Expr
mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
mkIdExpr sigs id =
let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
AST.PrimName src_name
-mkAssocElems ::
- [CoreSyn.CoreExpr] -- | The argument that are applied to function
- -> CoreSyn.CoreBndr -- | The binder in which to store the result
- -> Entity -- | The entity to map against.
- -> [AST.AssocElem] -- | The resulting port maps
-
-mkAssocElems args res entity =
- -- Create the actual AssocElems
- Maybe.catMaybes $ zipWith mkAssocElem ports sigs
- where
- -- Turn the ports and signals from a map into a flat list. This works,
- -- since the maps must have an identical form by definition. TODO: Check
- -- the similar form?
- arg_ports = ent_args entity
- res_port = ent_res entity
- -- Extract the id part from the (id, type) tuple
- ports = map (Monad.liftM fst) (res_port : arg_ports)
- -- Translate signal numbers into names
- sigs = (bndrToString res : map (bndrToString.varBndr) args)
-
--- Turns a Var CoreExpr into the Id inside it. Will of course only work for
--- simple Var CoreExprs, not complexer ones.
-varBndr :: CoreSyn.CoreExpr -> Var.Id
-varBndr (CoreSyn.Var id) = id
-
-- | Look up a signal in the signal name map
lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
lookupSigName sigs sig = name
name = Maybe.fromMaybe
(error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
(sigName info)
-
--- | 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 (mkVHDLExtId signal)))
-mkAssocElem Nothing _ = Nothing
-
--- | The VHDL Bit type
-bit_ty :: AST.TypeMark
-bit_ty = AST.unsafeVHDLBasicId "Bit"
-
--- | The VHDL Boolean type
-bool_ty :: AST.TypeMark
-bool_ty = AST.unsafeVHDLBasicId "Boolean"
-
--- | The VHDL std_logic
-std_logic_ty :: AST.TypeMark
-std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
+-}
-- Translate a Haskell type to a VHDL type
vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
let name = Name.getOccString (TyCon.tyConName tycon)
case name of
"TFVec" -> do
- res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) ty
+ res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
return $ Just $ (Arrow.second Right) res
-- "SizedWord" -> do
-- res <- mk_vector_ty (sized_word_len ty) ty
-- return $ Just $ (Arrow.second Left) res
"RangedWord" -> do
- res <- mk_natural_ty 0 (ranged_word_bound ty) ty
+ res <- mk_natural_ty 0 (ranged_word_bound ty)
return $ Just $ (Arrow.second Right) res
-- Create a custom type from this tycon
otherwise -> mk_tycon_ty tycon args
-- to work so far, though..
tyvars = TyCon.tyConTyVars tycon
subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
-
+
-- | Create a VHDL vector type
mk_vector_ty ::
Int -- ^ The length of the vector
-> Type.Type -- ^ The Haskell element type of the Vector
- -> Type.Type -- ^ The Haskell type to create a VHDL type for
-> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-mk_vector_ty len el_ty ty = do
+mk_vector_ty len el_ty = do
elem_types_map <- getA vsElemTypes
el_ty_tm <- vhdl_ty el_ty
let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
return (ty_id, ty_def)
Nothing -> do
let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
- let vec_def = AST.TDA $ AST.UnconsArrayDef [naturalTM] el_ty_tm
+ let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
- modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id))
+ modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
let ty_def = AST.SubtypeIn vec_id (Just range)
return (ty_id, ty_def)
mk_natural_ty ::
Int -- ^ The minimum bound (> 0)
-> Int -- ^ The maximum bound (> minimum bound)
- -> Type.Type -- ^ The Haskell type to create a VHDL type for
-> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-mk_natural_ty min_bound max_bound ty = do
+mk_natural_ty min_bound max_bound = do
let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
let ty_def = AST.SubtypeIn naturalTM (Just range)
- return (ty_id, ty_def)
-
-
-builtin_types =
- Map.fromList [
- ("Bit", std_logic_ty),
- ("Bool", bool_ty) -- TysWiredIn.boolTy
- ]
-
--- 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)
-
--- Creates a VHDL Id from a binder
-bndrToVHDLId ::
- CoreSyn.CoreBndr
- -> AST.VHDLId
-
-bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
-
--- Extracts the binder name as a String
-bndrToString ::
- CoreSyn.CoreBndr
- -> String
-bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
-
--- Get the string version a Var's unique
-varToStringUniq = show . Var.varUnique
-
--- Extracts the string version of the name
-nameToString :: Name.Name -> String
-nameToString = OccName.occNameString . Name.nameOccName
-
-recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
-
--- | Map a port specification of a builtin function to a VHDL Signal to put in
--- a VHDLSignalMap
-toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
-toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)
+ return (ty_id, ty_def)
\ No newline at end of file
projects / matthijs / master-project / cλash.git / blobdiff