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 IdInfo
32 import qualified TyCon
33 import qualified DataCon
34 import qualified CoreSubst
35 import Outputable ( showSDoc, ppr )
41 import TranslatorTypes
47 import GlobalNameTable
50 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
51 -> [(AST.VHDLId, AST.DesignFile)]
53 createDesignFiles binds =
54 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
55 map (Arrow.second $ AST.DesignFile full_context) units
58 init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
59 (units, final_session) =
60 State.runState (createLibraryUnits binds) init_session
61 ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
63 AST.Library $ mkVHDLBasicId "IEEE",
64 mkUseAll ["IEEE", "std_logic_1164"],
65 mkUseAll ["IEEE", "numeric_std"]
68 mkUseAll ["work", "types"]
70 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
72 -- Create a use foo.bar.all statement. Takes a list of components in the used
73 -- name. Must contain at least two components
74 mkUseAll :: [String] -> AST.ContextItem
76 AST.Use $ from AST.:.: AST.All
78 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
79 from = foldl select base_prefix (tail ss)
80 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
83 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
84 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
86 createLibraryUnits binds = do
87 entities <- Monad.mapM createEntity binds
88 archs <- Monad.mapM createArchitecture binds
91 let AST.EntityDec id _ = ent in
92 (id, [AST.LUEntity ent, AST.LUArch arch])
96 -- | Create an entity for a given function
98 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
99 -> VHDLState AST.EntityDec -- | The resulting entity
101 createEntity (fname, expr) = do
102 -- Strip off lambda's, these will be arguments
103 let (args, letexpr) = CoreSyn.collectBinders expr
104 args' <- Monad.mapM mkMap args
105 -- There must be a let at top level
106 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
108 let ent_decl' = createEntityAST fname args' res'
109 let AST.EntityDec entity_id _ = ent_decl'
110 let signature = Entity entity_id args' res'
111 modA vsSignatures (Map.insert (bndrToString fname) signature)
115 --[(SignalId, SignalInfo)]
117 -> VHDLState VHDLSignalMapElement
118 -- We only need the vsTypes element from the state
121 --info = Maybe.fromMaybe
122 -- (error $ "Signal not found in the name map? This should not happen!")
123 -- (lookup id sigmap)
124 -- Assume the bndr has a valid VHDL id already
125 id = bndrToVHDLId bndr
126 ty = Var.varType bndr
128 if True -- isPortSigUse $ sigUse info
130 type_mark <- vhdl_ty ty
131 return $ Just (id, type_mark)
136 -- | Create the VHDL AST for an entity
138 CoreSyn.CoreBndr -- | The name of the function
139 -> [VHDLSignalMapElement] -- | The entity's arguments
140 -> VHDLSignalMapElement -- | The entity's result
141 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
143 createEntityAST name args res =
144 AST.EntityDec vhdl_id ports
146 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
147 vhdl_id = mkVHDLBasicId $ bndrToString name
148 ports = Maybe.catMaybes $
149 map (mkIfaceSigDec AST.In) args
150 ++ [mkIfaceSigDec AST.Out res]
152 -- Add a clk port if we have state
153 clk_port = if True -- hasState hsfunc
155 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
159 -- | Create a port declaration
161 AST.Mode -- | The mode for the port (In / Out)
162 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
163 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
165 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
166 mkIfaceSigDec _ Nothing = Nothing
168 -- | Generate a VHDL entity name for the given hsfunc
170 -- TODO: This doesn't work for functions with multiple signatures!
171 -- Use a Basic Id, since using extended id's for entities throws off
172 -- precision and causes problems when generating filenames.
173 mkVHDLBasicId $ hsFuncName hsfunc
175 -- | Create an architecture for a given function
176 createArchitecture ::
177 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
178 -> VHDLState AST.ArchBody -- ^ The architecture for this function
180 createArchitecture (fname, expr) = do
181 --signaturemap <- getA vsSignatures
182 --let signature = Maybe.fromMaybe
183 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
184 -- (Map.lookup hsfunc signaturemap)
185 let entity_id = mkVHDLBasicId $ bndrToString fname
186 -- Strip off lambda's, these will be arguments
187 let (args, letexpr) = CoreSyn.collectBinders expr
188 -- There must be a let at top level
189 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
191 -- Create signal declarations for all internal and state signals
192 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
193 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
195 statements <- Monad.mapM mkConcSm binds
196 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
198 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
199 procs' = map AST.CSPSm procs
200 -- mkSigDec only uses vsTypes from the state
203 -- | Looks up all pairs of old state, new state signals, together with
204 -- the state id they represent.
205 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
206 makeStatePairs flatfunc =
207 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
208 | old_info <- map snd (flat_sigs flatfunc)
209 , new_info <- map snd (flat_sigs flatfunc)
210 -- old_info must be an old state (and, because of the next equality,
211 -- new_info must be a new state).
212 , Maybe.isJust $ oldStateId $ sigUse old_info
213 -- And the state numbers must match
214 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
216 -- Replace the second tuple element with the corresponding SignalInfo
217 --args_states = map (Arrow.second $ signalInfo sigs) args
218 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
219 mkStateProcSm (num, old, new) =
220 AST.ProcSm label [clk] [statement]
222 label = mkVHDLExtId $ "state_" ++ (show num)
223 clk = mkVHDLExtId "clk"
224 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
225 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
226 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
227 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
228 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
230 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
232 if True then do --isInternalSigUse use || isStateSigUse use then do
233 type_mark <- vhdl_ty $ Var.varType bndr
234 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
238 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
240 getSignalId :: SignalInfo -> AST.VHDLId
242 mkVHDLExtId $ Maybe.fromMaybe
243 (error $ "Unnamed signal? This should not happen!")
246 -- | Transforms a core binding into a VHDL concurrent statement
248 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
249 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
251 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
252 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
253 case Var.globalIdVarDetails f of
254 IdInfo.VanillaGlobal -> do
255 -- It's a global value imported from elsewhere. These can be builting
257 funSignatures <- getA vsNameTable
258 case (Map.lookup (bndrToString f) funSignatures) of
261 sigs = map (bndrToString.varBndr) args
262 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
263 func = (snd funSignature) sigsNames
264 src_wform = AST.Wform [AST.WformElem func Nothing]
265 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
266 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
268 return $ AST.CSSASm assign
269 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
270 IdInfo.NotGlobalId -> do
271 signatures <- getA vsSignatures
272 -- This is a local id, so it should be a function whose definition we
273 -- have and which can be turned into a component instantiation.
275 signature = Maybe.fromMaybe
276 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
277 (Map.lookup (bndrToString f) signatures)
278 entity_id = ent_id signature
279 label = bndrToString bndr
280 -- Add a clk port if we have state
281 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
282 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
283 portmaps = mkAssocElems args bndr signature
285 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
286 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
288 -- GHC generates some funny "r = r" bindings in let statements before
289 -- simplification. This outputs some dummy ConcSM for these, so things will at
290 -- least compile for now.
291 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
293 -- A single alt case must be a selector. This means thee scrutinee is a simple
294 -- variable, the alternative is a dataalt with a single non-wild binder that
296 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
298 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
299 case List.elemIndex sel_bndr bndrs of
301 labels <- getFieldLabels (Id.idType scrut)
302 let label = labels!!i
303 let sel_name = mkSelectedName scrut label
304 let sel_expr = AST.PrimName sel_name
305 return $ mkUncondAssign (Left bndr) sel_expr
306 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
308 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
310 -- Multiple case alt are be conditional assignments and have only wild
311 -- binders in the alts and only variables in the case values and a variable
312 -- for a scrutinee. We check the constructor of the second alt, since the
313 -- first is the default case, if there is any.
314 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
316 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
317 true_expr = (varToVHDLExpr true)
318 false_expr = (varToVHDLExpr false)
320 return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
321 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
322 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
324 -- Create an unconditional assignment statement
326 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
327 -> AST.Expr -- ^ The expression to assign
328 -> AST.ConcSm -- ^ The resulting concurrent statement
329 mkUncondAssign dst expr = mkAssign dst Nothing expr
331 -- Create a conditional assignment statement
333 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
334 -> AST.Expr -- ^ The condition
335 -> AST.Expr -- ^ The value when true
336 -> AST.Expr -- ^ The value when false
337 -> AST.ConcSm -- ^ The resulting concurrent statement
338 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
340 -- Create a conditional or unconditional assignment statement
342 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
343 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
344 -- and the value to assign when true.
345 AST.Expr -> -- ^ The value to assign when false or no condition
346 AST.ConcSm -- ^ The resulting concurrent statement
348 mkAssign dst cond false_expr =
350 -- I'm not 100% how this assignment AST works, but this gets us what we
352 whenelse = case cond of
353 Just (cond_expr, true_expr) ->
355 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
357 [AST.WhenElse true_wform cond_expr]
359 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
360 dst_name = case dst of
361 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
363 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
367 -- Create a record field selector that selects the given label from the record
368 -- stored in the given binder.
369 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
370 mkSelectedName bndr label =
372 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
373 sel_suffix = AST.SSimple $ label
375 AST.NSelected $ sel_prefix AST.:.: sel_suffix
377 -- Finds the field labels for VHDL type generated for the given Core type,
378 -- which must result in a record type.
379 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
380 getFieldLabels ty = do
381 -- Ensure that the type is generated (but throw away it's VHDLId)
383 -- Get the types map, lookup and unpack the VHDL TypeDef
384 types <- getA vsTypes
385 case Map.lookup (OrdType ty) types of
386 Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
387 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
389 -- Turn a variable reference into a AST expression
390 varToVHDLExpr :: Var.Var -> AST.Expr
391 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
393 -- Turn a constructor into an AST expression. For dataconstructors, this is
394 -- only the constructor itself, not any arguments it has. Should not be called
395 -- with a DEFAULT constructor.
396 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
397 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
399 tycon = DataCon.dataConTyCon dc
400 tyname = TyCon.tyConName tycon
401 dcname = DataCon.dataConName dc
402 lit = case Name.getOccString tyname of
403 -- TODO: Do something more robust than string matching
404 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
405 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
406 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
407 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
412 mkConcSm sigs (UncondDef src dst) _ = do
413 src_expr <- vhdl_expr src
414 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
415 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
416 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
417 return $ AST.CSSASm assign
419 vhdl_expr (Left id) = return $ mkIdExpr sigs id
420 vhdl_expr (Right expr) =
423 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
424 (Literal lit Nothing) ->
425 return $ AST.PrimLit lit
426 (Literal lit (Just ty)) -> do
427 -- Create a cast expression, which is just a function call using the
428 -- type name as the function name.
429 let litexpr = AST.PrimLit lit
431 let ty_name = AST.NSimple ty_id
432 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
433 return $ AST.PrimFCall $ AST.FCall ty_name args
435 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
437 mkConcSm sigs (CondDef cond true false dst) _ =
439 cond_expr = mkIdExpr sigs cond
440 true_expr = mkIdExpr sigs true
441 false_expr = mkIdExpr sigs false
442 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
443 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
444 whenelse = AST.WhenElse true_wform cond_expr
445 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
446 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
448 return $ AST.CSSASm assign
450 -- | Turn a SignalId into a VHDL Expr
451 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
453 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
454 AST.PrimName src_name
457 [CoreSyn.CoreExpr] -- | The argument that are applied to function
458 -> CoreSyn.CoreBndr -- | The binder in which to store the result
459 -> Entity -- | The entity to map against.
460 -> [AST.AssocElem] -- | The resulting port maps
462 mkAssocElems args res entity =
463 -- Create the actual AssocElems
464 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
466 -- Turn the ports and signals from a map into a flat list. This works,
467 -- since the maps must have an identical form by definition. TODO: Check
469 arg_ports = ent_args entity
470 res_port = ent_res entity
471 -- Extract the id part from the (id, type) tuple
472 ports = map (Monad.liftM fst) (res_port : arg_ports)
473 -- Translate signal numbers into names
474 sigs = (bndrToString res : map (bndrToString.varBndr) args)
476 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
477 -- simple Var CoreExprs, not complexer ones.
478 varBndr :: CoreSyn.CoreExpr -> Var.Id
479 varBndr (CoreSyn.Var id) = id
481 -- | Look up a signal in the signal name map
482 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
483 lookupSigName sigs sig = name
485 info = Maybe.fromMaybe
486 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
488 name = Maybe.fromMaybe
489 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
492 -- | Create an VHDL port -> signal association
493 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
494 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
495 mkAssocElem Nothing _ = Nothing
497 -- | The VHDL Bit type
498 bit_ty :: AST.TypeMark
499 bit_ty = AST.unsafeVHDLBasicId "Bit"
501 -- | The VHDL Boolean type
502 bool_ty :: AST.TypeMark
503 bool_ty = AST.unsafeVHDLBasicId "Boolean"
505 -- | The VHDL std_logic
506 std_logic_ty :: AST.TypeMark
507 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
509 -- Translate a Haskell type to a VHDL type
510 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
512 typemap <- getA vsTypes
513 let builtin_ty = do -- See if this is a tycon and lookup its name
514 (tycon, args) <- Type.splitTyConApp_maybe ty
515 let name = Name.getOccString (TyCon.tyConName tycon)
516 Map.lookup name builtin_types
517 -- If not a builtin type, try the custom types
518 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
519 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
520 -- Found a type, return it
522 -- No type yet, try to construct it
524 newty_maybe <- (construct_vhdl_ty ty)
526 Just (ty_id, ty_def) -> do
527 -- TODO: Check name uniqueness
528 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
530 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
532 -- Construct a new VHDL type for the given Haskell type.
533 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
534 construct_vhdl_ty ty = do
535 case Type.splitTyConApp_maybe ty of
536 Just (tycon, args) -> do
537 let name = Name.getOccString (TyCon.tyConName tycon)
540 res <- mk_vector_ty (tfvec_len ty) ty
543 res <- mk_vector_ty (sized_word_len ty) ty
545 -- Create a custom type from this tycon
546 otherwise -> mk_tycon_ty tycon args
547 Nothing -> return $ Nothing
549 -- | Create VHDL type for a custom tycon
550 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
551 mk_tycon_ty tycon args =
552 case TyCon.tyConDataCons tycon of
553 -- Not an algebraic type
554 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
556 let arg_tys = DataCon.dataConRepArgTys dc
557 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
558 -- violation? Or does it only mean not to apply it again to the same
560 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
561 elem_tys <- mapM vhdl_ty real_arg_tys
562 let elems = zipWith AST.ElementDec recordlabels elem_tys
563 -- For a single construct datatype, build a record with one field for
565 -- TODO: Add argument type ids to this, to ensure uniqueness
566 -- TODO: Special handling for tuples?
567 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
568 let ty_def = AST.TDR $ AST.RecordTypeDef elems
569 return $ Just (ty_id, ty_def)
570 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
572 -- Create a subst that instantiates all types passed to the tycon
573 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
574 -- to work so far, though..
575 tyvars = TyCon.tyConTyVars tycon
576 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
578 -- | Create a VHDL vector type
580 Int -- ^ The length of the vector
581 -> Type.Type -- ^ The Haskell type to create a VHDL type for
582 -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
584 mk_vector_ty len ty = do
585 -- Assume there is a single type argument
586 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
588 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
589 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
590 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
591 return (ty_id, ty_def)
596 ("Bit", std_logic_ty),
597 ("Bool", bool_ty) -- TysWiredIn.boolTy
601 -- Can only contain alphanumerics and underscores. The supplied string must be
602 -- a valid basic id, otherwise an error value is returned. This function is
603 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
605 mkVHDLBasicId :: String -> AST.VHDLId
607 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
609 -- Strip invalid characters.
610 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
611 -- Strip leading numbers and underscores
612 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
613 -- Strip multiple adjacent underscores
614 strip_multiscore = concat . map (\cs ->
620 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
621 -- different characters than basic ids, but can never be used to refer to
623 -- Use extended Ids for any values that are taken from the source file.
624 mkVHDLExtId :: String -> AST.VHDLId
626 AST.unsafeVHDLExtId $ strip_invalid s
628 -- Allowed characters, taken from ForSyde's mkVHDLExtId
629 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
630 strip_invalid = filter (`elem` allowed)
632 -- Creates a VHDL Id from a binder
637 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
639 -- Extracts the binder name as a String
644 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
646 -- Extracts the string version of the name
647 nameToString :: Name.Name -> String
648 nameToString = OccName.occNameString . Name.nameOccName
650 -- | A consise representation of a (set of) ports on a builtin function
651 --type PortMap = HsValueMap (String, AST.TypeMark)
652 -- | A consise representation of a builtin function
653 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
655 -- | Translate a list of concise representation of builtin functions to a
657 mkBuiltins :: [BuiltIn] -> SignatureMap
658 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
660 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
663 builtin_hsfuncs = Map.keys builtin_funcs
664 builtin_funcs = mkBuiltins
666 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
667 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
668 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
669 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
672 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
674 -- | Map a port specification of a builtin function to a VHDL Signal to put in
676 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
677 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)