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 Data.Accessor.MonadState as MonadState
import Debug.Trace
-- ForSyDe
-- GHC API
import CoreSyn
-import qualified Type
+--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 CoreSubst
import qualified CoreUtils
import Outputable ( showSDoc, ppr )
-- Local imports
import VHDLTypes
-import Flatten
-import FlattenTypes
-import TranslatorTypes
-import HsValueMap
+import VHDLTools
import Pretty
import CoreTools
import Constants
import Generate
-import GlobalNameTable
createDesignFiles ::
- [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
+ TypeState
+ -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
-> [(AST.VHDLId, AST.DesignFile)]
-createDesignFiles binds =
+createDesignFiles init_typestate binds =
(mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
map (Arrow.second $ AST.DesignFile full_context) units
where
- init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
+ init_session = VHDLState init_typestate Map.empty
(units, final_session) =
State.runState (createLibraryUnits binds) init_session
- 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))
+ tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns)
+ ty_decls = final_session ^. vsType ^. vsTypeDecls
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)
]
full_context =
mkUseAll ["work", "types"]
- : 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)
- mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
- mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
- mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
+ : (mkUseAll ["work"]
+ : ieee_context)
+ type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ ty_decls ++ subProgSpecs)
+ type_package_body = AST.LUPackageBody $ AST.PackageBody typesId tyfun_decls
+ subProgSpecs = map subProgSpec tyfun_decls
+ subProgSpec = \(AST.SubProgBody spec _ _) -> AST.PDISS spec
-- Create a use foo.bar.all statement. Takes a list of components in the used
-- name. Must contain at least two components
createLibraryUnits ::
[(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
- -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
+ -> VHDLSession [(AST.VHDLId, [AST.LibraryUnit])]
createLibraryUnits binds = do
entities <- Monad.mapM createEntity binds
-- | Create an entity for a given function
createEntity ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
- -> VHDLState AST.EntityDec -- | The resulting entity
+ -> VHDLSession AST.EntityDec -- | The resulting entity
createEntity (fname, expr) = do
-- Strip off lambda's, these will be arguments
-- There must be a let at top level
let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
res' <- mkMap res
- let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
+ let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
let ent_decl' = createEntityAST vhdl_id args' res'
let AST.EntityDec entity_id _ = ent_decl'
let signature = Entity entity_id args' res'
mkMap ::
--[(SignalId, SignalInfo)]
CoreSyn.CoreBndr
- -> VHDLState VHDLSignalMapElement
+ -> VHDLSession Port
-- We only need the vsTypes element from the state
mkMap = (\bndr ->
let
-- (error $ "Signal not found in the name map? This should not happen!")
-- (lookup id sigmap)
-- Assume the bndr has a valid VHDL id already
- id = bndrToVHDLId bndr
+ id = varToVHDLId bndr
ty = Var.varType bndr
- in
- if True -- isPortSigUse $ sigUse info
- then do
- type_mark <- vhdl_ty ty
- return $ Just (id, type_mark)
- else
- return $ Nothing
- )
+ error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
+ in do
+ type_mark <- MonadState.lift vsType $ vhdl_ty error_msg ty
+ return (id, type_mark)
+ )
-- | Create the VHDL AST for an entity
createEntityAST ::
AST.VHDLId -- | The name of the function
- -> [VHDLSignalMapElement] -- | The entity's arguments
- -> VHDLSignalMapElement -- | The entity's result
+ -> [Port] -- | The entity's arguments
+ -> Port -- | The entity's result
-> AST.EntityDec -- | The entity with the ent_decl filled in as well
createEntityAST vhdl_id args res =
AST.EntityDec vhdl_id ports
where
-- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
- ports = Maybe.catMaybes $
- map (mkIfaceSigDec AST.In) args
+ ports = map (mkIfaceSigDec AST.In) args
++ [mkIfaceSigDec AST.Out res]
++ [clk_port]
-- 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
- else
- Nothing
+ clk_port = AST.IfaceSigDec (mkVHDLExtId "clk") AST.In std_logicTM
-- | Create a port declaration
mkIfaceSigDec ::
AST.Mode -- | The mode for the port (In / Out)
- -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
- -> Maybe AST.IfaceSigDec -- | The resulting port declaration
+ -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
+ -> AST.IfaceSigDec -- | The resulting port declaration
-mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
-mkIfaceSigDec _ Nothing = Nothing
+mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
+{-
-- | 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 ::
(CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
- -> VHDLState AST.ArchBody -- ^ The architecture for this function
+ -> VHDLSession AST.ArchBody -- ^ The architecture for this function
createArchitecture (fname, expr) = do
signaturemap <- getA vsSignatures
let signature = Maybe.fromMaybe
- (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
+ (error $ "\nVHDL.createArchitecture: Generating architecture for function \n" ++ (pprString fname) ++ "\nwithout signature? This should not happen!")
(Map.lookup fname signaturemap)
let entity_id = ent_id signature
-- Strip off lambda's, these will be arguments
let (args, letexpr) = CoreSyn.collectBinders expr
-- There must be a let at top level
- let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
+ let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
- -- Create signal declarations for all internal and state signals
- sig_dec_maybes <- mapM (mkSigDec' . fst) binds
+ -- Create signal declarations for all binders in the let expression, except
+ -- for the output port (that will already have an output port declared in
+ -- the entity).
+ sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
let sig_decs = Maybe.catMaybes $ sig_dec_maybes
- statements <- Monad.mapM mkConcSm binds
+ statementss <- Monad.mapM mkConcSm binds
+ 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
-mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
-mkSigDec bndr =
- if True then do --isInternalSigUse use || isStateSigUse use then do
- type_mark <- vhdl_ty $ Var.varType bndr
- return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
- 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)
+ mkVHDLExtId $ Maybe.fromMaybe
+ (error $ "Unnamed signal? This should not happen!")
+ (sigName info)
+-}
+
+mkSigDec :: CoreSyn.CoreBndr -> VHDLSession (Maybe AST.SigDec)
+mkSigDec bndr =
+ if True then do --isInternalSigUse use || isStateSigUse use then do
+ let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString bndr
+ type_mark <- MonadState.lift vsType $ vhdl_ty error_msg (Var.varType bndr)
+ return $ Just (AST.SigDec (varToVHDLId bndr) type_mark Nothing)
+ else
+ return Nothing
-- | 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 instantiation.
+ -> VHDLSession [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)
+
+-- Simple a = b assignments are just like applications, but without arguments.
+-- We can't just generate an unconditional assignment here, since b might be a
+-- top level binding (e.g., a function with no arguments).
+mkConcSm (bndr, Var v) = do
+ genApplication (Left bndr) v []
mkConcSm (bndr, app@(CoreSyn.App _ _))= do
let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
- let valargs' = filter isValArg args
- let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
- case Var.globalIdVarDetails f of
- IdInfo.DataConWorkId dc ->
- -- It's a datacon. Create a record from its arguments.
- -- First, filter out type args. TODO: Is this the best way to do this?
- -- The types should already have been taken into acocunt when creating
- -- the signal, so this should probably work...
- --let valargs = filter isValArg args in
- if all is_var valargs then do
- labels <- getFieldLabels (CoreUtils.exprType app)
- let assigns = zipWith mkassign labels valargs
- let block_id = bndrToVHDLId bndr
- let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
- return $ AST.CSBSm block
- else
- error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
- where
- mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
- mkassign label (Var arg) =
- let sel_name = mkSelectedName bndr label in
- mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
- IdInfo.VanillaGlobal -> do
- -- It's a global value imported from elsewhere. These can be builtin
- -- functions.
- funSignatures <- getA vsNameTable
- 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
- 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
- IdInfo.NotGlobalId -> do
- signatures <- getA vsSignatures
- -- This is a local id, so it should be a function whose definition we
- -- have and which can be turned into a component instantiation.
- let
- signature = Maybe.fromMaybe
- (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
- (Map.lookup f signatures)
- entity_id = ent_id signature
- label = bndrToString bndr
- -- 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 [])
- portmaps = mkAssocElems args bndr signature
- in
- return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
- details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
-
--- GHC generates some funny "r = r" bindings in let statements before
--- simplification. This outputs some dummy ConcSM for these, so things will at
--- least compile for now.
-mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
+ let valargs = get_val_args (Var.varType f) args
+ genApplication (Left bndr) f (map Left valargs)
-- A single alt case must be a selector. This means thee scrutinee is a simple
-- variable, the alternative is a dataalt with a single non-wild binder that
(DataAlt dc, bndrs, (Var sel_bndr)) -> do
case List.elemIndex sel_bndr bndrs of
Just i -> do
- labels <- getFieldLabels (Id.idType scrut)
+ labels <- MonadState.lift vsType $ getFieldLabels (Id.idType scrut)
let label = labels!!i
- let sel_name = mkSelectedName scrut label
+ let sel_name = mkSelectedName (varToVHDLName scrut) label
let sel_expr = AST.PrimName sel_name
- return $ mkUncondAssign (Left bndr) sel_expr
- Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+ return [mkUncondAssign (Left bndr) sel_expr]
+ Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
- _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
+ _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
-- Multiple case alt are be conditional assignments and have only wild
-- binders in the alts and only variables in the case values and a variable
-- for a scrutinee. We check the constructor of the second alt, since the
-- 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)
- true_expr = (varToVHDLExpr true)
- false_expr = (varToVHDLExpr false)
- in
- return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
-mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
-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]
-getFieldLabels ty = do
- -- Ensure that the type is generated (but throw away it's VHDLId)
- vhdl_ty ty
- -- Get the types map, lookup and unpack the VHDL TypeDef
- types <- getA vsTypes
- case Map.lookup (OrdType ty) types of
- 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
- 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) = return $ mkIdExpr sigs id
- vhdl_expr (Right expr) =
- case expr of
- (EqLit id 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 <- 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) ->
- return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
-
-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
- return $ AST.CSSASm assign
--}
--- | 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
- where
- info = Maybe.fromMaybe
- (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
- (lookup sig sigs)
- 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
-vhdl_ty ty = do
- typemap <- getA vsTypes
- 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
- newty_maybe <- (construct_vhdl_ty ty)
- case newty_maybe of
- Just (ty_id, ty_def) -> do
- -- TODO: Check name uniqueness
- modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
- return ty_id
- Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
-
--- Construct a new VHDL type for the given Haskell type.
-construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-construct_vhdl_ty ty = do
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> do
- let name = Name.getOccString (TyCon.tyConName tycon)
- case name of
- "TFVec" -> do
- 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)
- return $ Just $ (Arrow.second Right) res
- -- Create a custom type from this tycon
- otherwise -> mk_tycon_ty tycon args
- Nothing -> return $ Nothing
-
--- | Create VHDL type for a custom tycon
-mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
-mk_tycon_ty tycon args =
- case TyCon.tyConDataCons tycon of
- -- Not an algebraic type
- [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
- [dc] -> do
- let arg_tys = DataCon.dataConRepArgTys dc
- -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
- -- violation? Or does it only mean not to apply it again to the same
- -- subject?
- let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
- elem_tys <- mapM vhdl_ty real_arg_tys
- let elems = zipWith AST.ElementDec recordlabels elem_tys
- -- For a single construct datatype, build a record with one field for
- -- each argument.
- -- TODO: Add argument type ids to this, to ensure uniqueness
- -- TODO: Special handling for tuples?
- let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
- let ty_def = AST.TDR $ AST.RecordTypeDef elems
- return $ Just (ty_id, Left ty_def)
- dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
- where
- -- Create a subst that instantiates all types passed to the tycon
- -- TODO: I'm not 100% sure that this is the right way to do this. It seems
- -- 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
- -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-
-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)
- let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
- let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
- case existing_elem_ty of
- Just t -> do
- let ty_def = AST.SubtypeIn t (Just range)
- return (ty_id, ty_def)
- Nothing -> do
- let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId 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 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)
- -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
-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)
+mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do
+ scrut' <- MonadState.lift vsType $ varToVHDLExpr scrut
+ let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
+ true_expr <- MonadState.lift vsType $ varToVHDLExpr true
+ false_expr <- MonadState.lift vsType $ varToVHDLExpr false
+ return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
+
+mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
+mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
+mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
projects / matthijs / master-project / cλash.git / blobdiff