2 -- Functions to generate VHDL from FlatFunctions
7 import qualified Data.Foldable as Foldable
8 import qualified Data.List as List
9 import qualified Data.Map as Map
10 import qualified Maybe
11 import qualified Control.Monad as Monad
12 import qualified Control.Arrow as Arrow
13 import qualified Control.Monad.Trans.State as State
14 import qualified Data.Traversable as Traversable
15 import qualified Data.Monoid as Monoid
17 import qualified Data.Accessor.MonadState as MonadState
18 import Text.Regex.Posix
22 import qualified ForSyDe.Backend.VHDL.AST as AST
28 import qualified OccName
31 import qualified TyCon
32 import qualified DataCon
33 import qualified CoreSubst
34 import Outputable ( showSDoc, ppr )
40 import TranslatorTypes
46 import GlobalNameTable
49 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
50 -> [(AST.VHDLId, AST.DesignFile)]
52 createDesignFiles binds =
53 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
54 map (Arrow.second $ AST.DesignFile full_context) units
57 init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
58 (units, final_session) =
59 State.runState (createLibraryUnits binds) init_session
60 ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
62 AST.Library $ mkVHDLBasicId "IEEE",
63 mkUseAll ["IEEE", "std_logic_1164"],
64 mkUseAll ["IEEE", "numeric_std"]
67 mkUseAll ["work", "types"]
69 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
71 -- Create a use foo.bar.all statement. Takes a list of components in the used
72 -- name. Must contain at least two components
73 mkUseAll :: [String] -> AST.ContextItem
75 AST.Use $ from AST.:.: AST.All
77 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
78 from = foldl select base_prefix (tail ss)
79 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
82 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
83 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
85 createLibraryUnits binds = do
86 entities <- Monad.mapM createEntity binds
87 archs <- Monad.mapM createArchitecture binds
90 let AST.EntityDec id _ = ent in
91 (id, [AST.LUEntity ent, AST.LUArch arch])
95 -- | Create an entity for a given function
97 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
98 -> VHDLState AST.EntityDec -- | The resulting entity
100 createEntity (fname, expr) = do
101 -- Strip off lambda's, these will be arguments
102 let (args, letexpr) = CoreSyn.collectBinders expr
103 args' <- Monad.mapM mkMap args
104 -- There must be a let at top level
105 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
107 let ent_decl' = createEntityAST fname args' res'
108 let AST.EntityDec entity_id _ = ent_decl'
109 let signature = Entity entity_id args' res'
110 modA vsSignatures (Map.insert (bndrToString fname) signature)
114 --[(SignalId, SignalInfo)]
116 -> VHDLState VHDLSignalMapElement
117 -- We only need the vsTypes element from the state
120 --info = Maybe.fromMaybe
121 -- (error $ "Signal not found in the name map? This should not happen!")
122 -- (lookup id sigmap)
123 -- Assume the bndr has a valid VHDL id already
124 id = bndrToVHDLId bndr
125 ty = Var.varType bndr
127 if True -- isPortSigUse $ sigUse info
129 type_mark <- vhdl_ty ty
130 return $ Just (id, type_mark)
135 -- | Create the VHDL AST for an entity
137 CoreSyn.CoreBndr -- | The name of the function
138 -> [VHDLSignalMapElement] -- | The entity's arguments
139 -> VHDLSignalMapElement -- | The entity's result
140 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
142 createEntityAST name args res =
143 AST.EntityDec vhdl_id ports
145 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
146 vhdl_id = mkVHDLBasicId $ bndrToString name
147 ports = Maybe.catMaybes $
148 map (mkIfaceSigDec AST.In) args
149 ++ [mkIfaceSigDec AST.Out res]
151 -- Add a clk port if we have state
152 clk_port = if True -- hasState hsfunc
154 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
158 -- | Create a port declaration
160 AST.Mode -- | The mode for the port (In / Out)
161 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
162 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
164 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
165 mkIfaceSigDec _ Nothing = Nothing
167 -- | Generate a VHDL entity name for the given hsfunc
169 -- TODO: This doesn't work for functions with multiple signatures!
170 -- Use a Basic Id, since using extended id's for entities throws off
171 -- precision and causes problems when generating filenames.
172 mkVHDLBasicId $ hsFuncName hsfunc
174 -- | Create an architecture for a given function
175 createArchitecture ::
176 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
177 -> VHDLState AST.ArchBody -- ^ The architecture for this function
179 createArchitecture (fname, expr) = do
180 --signaturemap <- getA vsSignatures
181 --let signature = Maybe.fromMaybe
182 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
183 -- (Map.lookup hsfunc signaturemap)
184 let entity_id = mkVHDLBasicId $ bndrToString fname
185 -- Strip off lambda's, these will be arguments
186 let (args, letexpr) = CoreSyn.collectBinders expr
187 -- There must be a let at top level
188 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
190 -- Create signal declarations for all internal and state signals
191 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
192 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
194 statements <- Monad.mapM mkConcSm binds
195 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
197 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
198 procs' = map AST.CSPSm procs
199 -- mkSigDec only uses vsTypes from the state
202 -- | Looks up all pairs of old state, new state signals, together with
203 -- the state id they represent.
204 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
205 makeStatePairs flatfunc =
206 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
207 | old_info <- map snd (flat_sigs flatfunc)
208 , new_info <- map snd (flat_sigs flatfunc)
209 -- old_info must be an old state (and, because of the next equality,
210 -- new_info must be a new state).
211 , Maybe.isJust $ oldStateId $ sigUse old_info
212 -- And the state numbers must match
213 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
215 -- Replace the second tuple element with the corresponding SignalInfo
216 --args_states = map (Arrow.second $ signalInfo sigs) args
217 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
218 mkStateProcSm (num, old, new) =
219 AST.ProcSm label [clk] [statement]
221 label = mkVHDLExtId $ "state_" ++ (show num)
222 clk = mkVHDLExtId "clk"
223 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
224 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
225 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
226 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
227 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
229 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
231 if True then do --isInternalSigUse use || isStateSigUse use then do
232 type_mark <- vhdl_ty $ Var.varType bndr
233 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
237 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
239 getSignalId :: SignalInfo -> AST.VHDLId
241 mkVHDLExtId $ Maybe.fromMaybe
242 (error $ "Unnamed signal? This should not happen!")
245 -- | Transforms a core binding into a VHDL concurrent statement
247 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
248 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
250 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
251 signatures <- getA vsSignatures
252 funSignatures <- getA vsNameTable
253 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
254 case (Map.lookup (bndrToString f) funSignatures) of
257 sigs = map (bndrToString.varBndr) args
258 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
259 func = (snd funSignature) sigsNames
260 src_wform = AST.Wform [AST.WformElem func Nothing]
261 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
262 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
264 return $ AST.CSSASm assign
267 signature = Maybe.fromMaybe
268 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
269 (Map.lookup (bndrToString f) signatures)
270 entity_id = ent_id signature
271 label = bndrToString bndr
272 -- Add a clk port if we have state
273 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
274 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
275 portmaps = mkAssocElems args bndr signature
277 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
279 -- GHC generates some funny "r = r" bindings in let statements before
280 -- simplification. This outputs some dummy ConcSM for these, so things will at
281 -- least compile for now.
282 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
284 -- A single alt case must be a selector. This means thee scrutinee is a simple
285 -- variable, the alternative is a dataalt with a single non-wild binder that
287 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
289 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
290 case List.elemIndex sel_bndr bndrs of
292 labels <- getFieldLabels (Id.idType scrut)
293 let label = labels!!i
294 let scrut_name = AST.NSimple $ bndrToVHDLId scrut
295 let sel_suffix = AST.SSimple $ label
296 let sel_name = AST.NSelected $ scrut_name AST.:.: sel_suffix
297 let sel_expr = AST.PrimName sel_name
298 return $ mkUncondAssign bndr sel_expr
299 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
301 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
304 -- Multiple case alt are be conditional assignments and have only wild
305 -- binders in the alts and only variables in the case values and a variable
306 -- for a scrutinee. We check the constructor of the second alt, since the
307 -- first is the default case, if there is any.
308 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
310 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
311 true_expr = (varToVHDLExpr true)
312 false_expr = (varToVHDLExpr false)
314 return $ mkCondAssign bndr cond_expr true_expr false_expr
315 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
316 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
318 -- Create an unconditional assignment statement
320 CoreBndr -- ^ The signal to assign to
321 -> AST.Expr -- ^ The expression to assign
322 -> AST.ConcSm -- ^ The resulting concurrent statement
323 mkUncondAssign bndr expr = mkAssign bndr Nothing expr
325 -- Create a conditional assignment statement
327 CoreBndr -- ^ The signal to assign to
328 -> AST.Expr -- ^ The condition
329 -> AST.Expr -- ^ The value when true
330 -> AST.Expr -- ^ The value when false
331 -> AST.ConcSm -- ^ The resulting concurrent statement
332 mkCondAssign bndr cond true false = mkAssign bndr (Just (cond, true)) false
334 -- Create a conditional or unconditional assignment statement
336 CoreBndr -> -- ^ The signal to assign to
337 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
338 -- and the value to assign when true.
339 AST.Expr -> -- ^ The value to assign when false or no condition
340 AST.ConcSm -- ^ The resulting concurrent statement
342 mkAssign bndr cond false_expr =
344 -- I'm not 100% how this assignment AST works, but this gets us what we
346 whenelse = case cond of
347 Just (cond_expr, true_expr) ->
349 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
351 [AST.WhenElse true_wform cond_expr]
353 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
354 dst_name = AST.NSimple (bndrToVHDLId bndr)
355 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
359 -- Finds the field labels for VHDL type generated for the given Core type,
360 -- which must result in a record type.
361 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
362 getFieldLabels ty = do
363 -- Ensure that the type is generated (but throw away it's VHDLId)
365 -- Get the types map, lookup and unpack the VHDL TypeDef
366 types <- getA vsTypes
367 case Map.lookup (OrdType ty) types of
368 Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
369 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
371 -- Turn a variable reference into a AST expression
372 varToVHDLExpr :: Var.Var -> AST.Expr
373 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
375 -- Turn a constructor into an AST expression. For dataconstructors, this is
376 -- only the constructor itself, not any arguments it has. Should not be called
377 -- with a DEFAULT constructor.
378 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
379 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
381 tycon = DataCon.dataConTyCon dc
382 tyname = TyCon.tyConName tycon
383 dcname = DataCon.dataConName dc
384 lit = case Name.getOccString tyname of
385 -- TODO: Do something more robust than string matching
386 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
387 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
388 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
389 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
394 mkConcSm sigs (UncondDef src dst) _ = do
395 src_expr <- vhdl_expr src
396 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
397 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
398 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
399 return $ AST.CSSASm assign
401 vhdl_expr (Left id) = return $ mkIdExpr sigs id
402 vhdl_expr (Right expr) =
405 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
406 (Literal lit Nothing) ->
407 return $ AST.PrimLit lit
408 (Literal lit (Just ty)) -> do
409 -- Create a cast expression, which is just a function call using the
410 -- type name as the function name.
411 let litexpr = AST.PrimLit lit
413 let ty_name = AST.NSimple ty_id
414 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
415 return $ AST.PrimFCall $ AST.FCall ty_name args
417 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
419 mkConcSm sigs (CondDef cond true false dst) _ =
421 cond_expr = mkIdExpr sigs cond
422 true_expr = mkIdExpr sigs true
423 false_expr = mkIdExpr sigs false
424 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
425 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
426 whenelse = AST.WhenElse true_wform cond_expr
427 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
428 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
430 return $ AST.CSSASm assign
432 -- | Turn a SignalId into a VHDL Expr
433 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
435 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
436 AST.PrimName src_name
439 [CoreSyn.CoreExpr] -- | The argument that are applied to function
440 -> CoreSyn.CoreBndr -- | The binder in which to store the result
441 -> Entity -- | The entity to map against.
442 -> [AST.AssocElem] -- | The resulting port maps
444 mkAssocElems args res entity =
445 -- Create the actual AssocElems
446 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
448 -- Turn the ports and signals from a map into a flat list. This works,
449 -- since the maps must have an identical form by definition. TODO: Check
451 arg_ports = ent_args entity
452 res_port = ent_res entity
453 -- Extract the id part from the (id, type) tuple
454 ports = map (Monad.liftM fst) (res_port : arg_ports)
455 -- Translate signal numbers into names
456 sigs = (bndrToString res : map (bndrToString.varBndr) args)
458 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
459 -- simple Var CoreExprs, not complexer ones.
460 varBndr :: CoreSyn.CoreExpr -> Var.Id
461 varBndr (CoreSyn.Var id) = id
463 -- | Look up a signal in the signal name map
464 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
465 lookupSigName sigs sig = name
467 info = Maybe.fromMaybe
468 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
470 name = Maybe.fromMaybe
471 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
474 -- | Create an VHDL port -> signal association
475 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
476 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
477 mkAssocElem Nothing _ = Nothing
479 -- | The VHDL Bit type
480 bit_ty :: AST.TypeMark
481 bit_ty = AST.unsafeVHDLBasicId "Bit"
483 -- | The VHDL Boolean type
484 bool_ty :: AST.TypeMark
485 bool_ty = AST.unsafeVHDLBasicId "Boolean"
487 -- | The VHDL std_logic
488 std_logic_ty :: AST.TypeMark
489 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
491 -- Translate a Haskell type to a VHDL type
492 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
494 typemap <- getA vsTypes
495 let builtin_ty = do -- See if this is a tycon and lookup its name
496 (tycon, args) <- Type.splitTyConApp_maybe ty
497 let name = Name.getOccString (TyCon.tyConName tycon)
498 Map.lookup name builtin_types
499 -- If not a builtin type, try the custom types
500 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
501 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
502 -- Found a type, return it
504 -- No type yet, try to construct it
506 newty_maybe <- (construct_vhdl_ty ty)
508 Just (ty_id, ty_def) -> do
509 -- TODO: Check name uniqueness
510 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
512 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
514 -- Construct a new VHDL type for the given Haskell type.
515 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
516 construct_vhdl_ty ty = do
517 case Type.splitTyConApp_maybe ty of
518 Just (tycon, args) -> do
519 let name = Name.getOccString (TyCon.tyConName tycon)
522 res <- mk_vector_ty (tfvec_len ty) ty
525 res <- mk_vector_ty (sized_word_len ty) ty
527 -- Create a custom type from this tycon
528 otherwise -> mk_tycon_ty tycon args
529 Nothing -> return $ Nothing
531 -- | Create VHDL type for a custom tycon
532 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
533 mk_tycon_ty tycon args =
534 case TyCon.tyConDataCons tycon of
535 -- Not an algebraic type
536 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
538 let arg_tys = DataCon.dataConRepArgTys dc
539 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
540 -- violation? Or does it only mean not to apply it again to the same
542 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
543 elem_tys <- mapM vhdl_ty real_arg_tys
544 let elems = zipWith AST.ElementDec recordlabels elem_tys
545 -- For a single construct datatype, build a record with one field for
547 -- TODO: Add argument type ids to this, to ensure uniqueness
548 -- TODO: Special handling for tuples?
549 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
550 let ty_def = AST.TDR $ AST.RecordTypeDef elems
551 return $ Just (ty_id, ty_def)
552 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
554 -- Create a subst that instantiates all types passed to the tycon
555 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
556 -- to work so far, though..
557 tyvars = TyCon.tyConTyVars tycon
558 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
560 -- | Create a VHDL vector type
562 Int -- ^ The length of the vector
563 -> Type.Type -- ^ The Haskell type to create a VHDL type for
564 -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
566 mk_vector_ty len ty = do
567 -- Assume there is a single type argument
568 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
570 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
571 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
572 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
573 return (ty_id, ty_def)
578 ("Bit", std_logic_ty),
579 ("Bool", bool_ty) -- TysWiredIn.boolTy
583 -- Can only contain alphanumerics and underscores. The supplied string must be
584 -- a valid basic id, otherwise an error value is returned. This function is
585 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
587 mkVHDLBasicId :: String -> AST.VHDLId
589 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
591 -- Strip invalid characters.
592 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
593 -- Strip leading numbers and underscores
594 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
595 -- Strip multiple adjacent underscores
596 strip_multiscore = concat . map (\cs ->
602 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
603 -- different characters than basic ids, but can never be used to refer to
605 -- Use extended Ids for any values that are taken from the source file.
606 mkVHDLExtId :: String -> AST.VHDLId
608 AST.unsafeVHDLExtId $ strip_invalid s
610 -- Allowed characters, taken from ForSyde's mkVHDLExtId
611 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
612 strip_invalid = filter (`elem` allowed)
614 -- Creates a VHDL Id from a binder
619 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
621 -- Extracts the binder name as a String
626 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
628 -- Extracts the string version of the name
629 nameToString :: Name.Name -> String
630 nameToString = OccName.occNameString . Name.nameOccName
632 -- | A consise representation of a (set of) ports on a builtin function
633 --type PortMap = HsValueMap (String, AST.TypeMark)
634 -- | A consise representation of a builtin function
635 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
637 -- | Translate a list of concise representation of builtin functions to a
639 mkBuiltins :: [BuiltIn] -> SignatureMap
640 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
642 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
645 builtin_hsfuncs = Map.keys builtin_funcs
646 builtin_funcs = mkBuiltins
648 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
649 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
650 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
651 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
654 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
656 -- | Map a port specification of a builtin function to a VHDL Signal to put in
658 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
659 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)