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 qualified CoreUtils
36 import Outputable ( showSDoc, ppr )
42 import TranslatorTypes
48 import GlobalNameTable
51 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
52 -> [(AST.VHDLId, AST.DesignFile)]
54 createDesignFiles binds =
55 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
56 map (Arrow.second $ AST.DesignFile full_context) units
59 init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
60 (units, final_session) =
61 State.runState (createLibraryUnits binds) init_session
62 ty_decls = map (uncurry AST.TypeDec) $ Map.elems (final_session ^. vsTypes)
64 AST.Library $ mkVHDLBasicId "IEEE",
65 mkUseAll ["IEEE", "std_logic_1164"],
66 mkUseAll ["IEEE", "numeric_std"]
69 mkUseAll ["work", "types"]
71 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map AST.PDITD ty_decls)
73 -- Create a use foo.bar.all statement. Takes a list of components in the used
74 -- name. Must contain at least two components
75 mkUseAll :: [String] -> AST.ContextItem
77 AST.Use $ from AST.:.: AST.All
79 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
80 from = foldl select base_prefix (tail ss)
81 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
84 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
85 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
87 createLibraryUnits binds = do
88 entities <- Monad.mapM createEntity binds
89 archs <- Monad.mapM createArchitecture binds
92 let AST.EntityDec id _ = ent in
93 (id, [AST.LUEntity ent, AST.LUArch arch])
97 -- | Create an entity for a given function
99 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
100 -> VHDLState AST.EntityDec -- | The resulting entity
102 createEntity (fname, expr) = do
103 -- Strip off lambda's, these will be arguments
104 let (args, letexpr) = CoreSyn.collectBinders expr
105 args' <- Monad.mapM mkMap args
106 -- There must be a let at top level
107 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
109 let ent_decl' = createEntityAST fname args' res'
110 let AST.EntityDec entity_id _ = ent_decl'
111 let signature = Entity entity_id args' res'
112 modA vsSignatures (Map.insert (bndrToString fname) signature)
116 --[(SignalId, SignalInfo)]
118 -> VHDLState VHDLSignalMapElement
119 -- We only need the vsTypes element from the state
122 --info = Maybe.fromMaybe
123 -- (error $ "Signal not found in the name map? This should not happen!")
124 -- (lookup id sigmap)
125 -- Assume the bndr has a valid VHDL id already
126 id = bndrToVHDLId bndr
127 ty = Var.varType bndr
129 if True -- isPortSigUse $ sigUse info
131 type_mark <- vhdl_ty ty
132 return $ Just (id, type_mark)
137 -- | Create the VHDL AST for an entity
139 CoreSyn.CoreBndr -- | The name of the function
140 -> [VHDLSignalMapElement] -- | The entity's arguments
141 -> VHDLSignalMapElement -- | The entity's result
142 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
144 createEntityAST name args res =
145 AST.EntityDec vhdl_id ports
147 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
148 vhdl_id = mkVHDLBasicId $ bndrToString name
149 ports = Maybe.catMaybes $
150 map (mkIfaceSigDec AST.In) args
151 ++ [mkIfaceSigDec AST.Out res]
153 -- Add a clk port if we have state
154 clk_port = if True -- hasState hsfunc
156 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
160 -- | Create a port declaration
162 AST.Mode -- | The mode for the port (In / Out)
163 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
164 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
166 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
167 mkIfaceSigDec _ Nothing = Nothing
169 -- | Generate a VHDL entity name for the given hsfunc
171 -- TODO: This doesn't work for functions with multiple signatures!
172 -- Use a Basic Id, since using extended id's for entities throws off
173 -- precision and causes problems when generating filenames.
174 mkVHDLBasicId $ hsFuncName hsfunc
176 -- | Create an architecture for a given function
177 createArchitecture ::
178 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
179 -> VHDLState AST.ArchBody -- ^ The architecture for this function
181 createArchitecture (fname, expr) = do
182 --signaturemap <- getA vsSignatures
183 --let signature = Maybe.fromMaybe
184 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
185 -- (Map.lookup hsfunc signaturemap)
186 let entity_id = mkVHDLBasicId $ bndrToString fname
187 -- Strip off lambda's, these will be arguments
188 let (args, letexpr) = CoreSyn.collectBinders expr
189 -- There must be a let at top level
190 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
192 -- Create signal declarations for all internal and state signals
193 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
194 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
196 statements <- Monad.mapM mkConcSm binds
197 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
199 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
200 procs' = map AST.CSPSm procs
201 -- mkSigDec only uses vsTypes from the state
204 -- | Looks up all pairs of old state, new state signals, together with
205 -- the state id they represent.
206 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
207 makeStatePairs flatfunc =
208 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
209 | old_info <- map snd (flat_sigs flatfunc)
210 , new_info <- map snd (flat_sigs flatfunc)
211 -- old_info must be an old state (and, because of the next equality,
212 -- new_info must be a new state).
213 , Maybe.isJust $ oldStateId $ sigUse old_info
214 -- And the state numbers must match
215 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
217 -- Replace the second tuple element with the corresponding SignalInfo
218 --args_states = map (Arrow.second $ signalInfo sigs) args
219 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
220 mkStateProcSm (num, old, new) =
221 AST.ProcSm label [clk] [statement]
223 label = mkVHDLExtId $ "state_" ++ (show num)
224 clk = mkVHDLExtId "clk"
225 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
226 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
227 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
228 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
229 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
231 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
233 if True then do --isInternalSigUse use || isStateSigUse use then do
234 type_mark <- vhdl_ty $ Var.varType bndr
235 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
239 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
241 getSignalId :: SignalInfo -> AST.VHDLId
243 mkVHDLExtId $ Maybe.fromMaybe
244 (error $ "Unnamed signal? This should not happen!")
247 -- | Transforms a core binding into a VHDL concurrent statement
249 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
250 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
252 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
253 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
254 case Var.globalIdVarDetails f of
255 IdInfo.DataConWorkId dc ->
256 -- It's a datacon. Create a record from its arguments.
257 -- First, filter out type args. TODO: Is this the best way to do this?
258 -- The types should already have been taken into acocunt when creating
259 -- the signal, so this should probably work...
260 let valargs = filter isValArg args in
261 if all is_var valargs then do
262 labels <- getFieldLabels (CoreUtils.exprType app)
263 let assigns = zipWith mkassign labels valargs
264 let block_id = bndrToVHDLId bndr
265 let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
266 return $ AST.CSBSm block
268 error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
270 mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
271 mkassign label (Var arg) =
272 let sel_name = mkSelectedName bndr label in
273 mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
274 IdInfo.VanillaGlobal -> do
275 -- It's a global value imported from elsewhere. These can be builting
277 funSignatures <- getA vsNameTable
278 case (Map.lookup (bndrToString f) funSignatures) of
281 sigs = map (bndrToString.varBndr) args
282 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
283 func = (snd funSignature) sigsNames
284 src_wform = AST.Wform [AST.WformElem func Nothing]
285 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
286 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
288 return $ AST.CSSASm assign
289 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
290 IdInfo.NotGlobalId -> do
291 signatures <- getA vsSignatures
292 -- This is a local id, so it should be a function whose definition we
293 -- have and which can be turned into a component instantiation.
295 signature = Maybe.fromMaybe
296 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
297 (Map.lookup (bndrToString f) signatures)
298 entity_id = ent_id signature
299 label = bndrToString bndr
300 -- Add a clk port if we have state
301 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
302 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
303 portmaps = mkAssocElems args bndr signature
305 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
306 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
308 -- GHC generates some funny "r = r" bindings in let statements before
309 -- simplification. This outputs some dummy ConcSM for these, so things will at
310 -- least compile for now.
311 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
313 -- A single alt case must be a selector. This means thee scrutinee is a simple
314 -- variable, the alternative is a dataalt with a single non-wild binder that
316 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
318 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
319 case List.elemIndex sel_bndr bndrs of
321 labels <- getFieldLabels (Id.idType scrut)
322 let label = labels!!i
323 let sel_name = mkSelectedName scrut label
324 let sel_expr = AST.PrimName sel_name
325 return $ mkUncondAssign (Left bndr) sel_expr
326 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
328 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
330 -- Multiple case alt are be conditional assignments and have only wild
331 -- binders in the alts and only variables in the case values and a variable
332 -- for a scrutinee. We check the constructor of the second alt, since the
333 -- first is the default case, if there is any.
334 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
336 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
337 true_expr = (varToVHDLExpr true)
338 false_expr = (varToVHDLExpr false)
340 return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
341 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
342 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
344 -- Create an unconditional assignment statement
346 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
347 -> AST.Expr -- ^ The expression to assign
348 -> AST.ConcSm -- ^ The resulting concurrent statement
349 mkUncondAssign dst expr = mkAssign dst Nothing expr
351 -- Create a conditional assignment statement
353 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
354 -> AST.Expr -- ^ The condition
355 -> AST.Expr -- ^ The value when true
356 -> AST.Expr -- ^ The value when false
357 -> AST.ConcSm -- ^ The resulting concurrent statement
358 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
360 -- Create a conditional or unconditional assignment statement
362 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
363 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
364 -- and the value to assign when true.
365 AST.Expr -> -- ^ The value to assign when false or no condition
366 AST.ConcSm -- ^ The resulting concurrent statement
368 mkAssign dst cond false_expr =
370 -- I'm not 100% how this assignment AST works, but this gets us what we
372 whenelse = case cond of
373 Just (cond_expr, true_expr) ->
375 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
377 [AST.WhenElse true_wform cond_expr]
379 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
380 dst_name = case dst of
381 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
383 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
387 -- Create a record field selector that selects the given label from the record
388 -- stored in the given binder.
389 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
390 mkSelectedName bndr label =
392 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
393 sel_suffix = AST.SSimple $ label
395 AST.NSelected $ sel_prefix AST.:.: sel_suffix
397 -- Finds the field labels for VHDL type generated for the given Core type,
398 -- which must result in a record type.
399 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
400 getFieldLabels ty = do
401 -- Ensure that the type is generated (but throw away it's VHDLId)
403 -- Get the types map, lookup and unpack the VHDL TypeDef
404 types <- getA vsTypes
405 case Map.lookup (OrdType ty) types of
406 Just (_, AST.TDR (AST.RecordTypeDef elems)) -> return $ map (\(AST.ElementDec id _) -> id) elems
407 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
409 -- Turn a variable reference into a AST expression
410 varToVHDLExpr :: Var.Var -> AST.Expr
411 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
413 -- Turn a constructor into an AST expression. For dataconstructors, this is
414 -- only the constructor itself, not any arguments it has. Should not be called
415 -- with a DEFAULT constructor.
416 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
417 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
419 tycon = DataCon.dataConTyCon dc
420 tyname = TyCon.tyConName tycon
421 dcname = DataCon.dataConName dc
422 lit = case Name.getOccString tyname of
423 -- TODO: Do something more robust than string matching
424 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
425 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
426 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
427 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
432 mkConcSm sigs (UncondDef src dst) _ = do
433 src_expr <- vhdl_expr src
434 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
435 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
436 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
437 return $ AST.CSSASm assign
439 vhdl_expr (Left id) = return $ mkIdExpr sigs id
440 vhdl_expr (Right expr) =
443 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
444 (Literal lit Nothing) ->
445 return $ AST.PrimLit lit
446 (Literal lit (Just ty)) -> do
447 -- Create a cast expression, which is just a function call using the
448 -- type name as the function name.
449 let litexpr = AST.PrimLit lit
451 let ty_name = AST.NSimple ty_id
452 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
453 return $ AST.PrimFCall $ AST.FCall ty_name args
455 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
457 mkConcSm sigs (CondDef cond true false dst) _ =
459 cond_expr = mkIdExpr sigs cond
460 true_expr = mkIdExpr sigs true
461 false_expr = mkIdExpr sigs false
462 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
463 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
464 whenelse = AST.WhenElse true_wform cond_expr
465 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
466 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
468 return $ AST.CSSASm assign
470 -- | Turn a SignalId into a VHDL Expr
471 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
473 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
474 AST.PrimName src_name
477 [CoreSyn.CoreExpr] -- | The argument that are applied to function
478 -> CoreSyn.CoreBndr -- | The binder in which to store the result
479 -> Entity -- | The entity to map against.
480 -> [AST.AssocElem] -- | The resulting port maps
482 mkAssocElems args res entity =
483 -- Create the actual AssocElems
484 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
486 -- Turn the ports and signals from a map into a flat list. This works,
487 -- since the maps must have an identical form by definition. TODO: Check
489 arg_ports = ent_args entity
490 res_port = ent_res entity
491 -- Extract the id part from the (id, type) tuple
492 ports = map (Monad.liftM fst) (res_port : arg_ports)
493 -- Translate signal numbers into names
494 sigs = (bndrToString res : map (bndrToString.varBndr) args)
496 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
497 -- simple Var CoreExprs, not complexer ones.
498 varBndr :: CoreSyn.CoreExpr -> Var.Id
499 varBndr (CoreSyn.Var id) = id
501 -- | Look up a signal in the signal name map
502 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
503 lookupSigName sigs sig = name
505 info = Maybe.fromMaybe
506 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
508 name = Maybe.fromMaybe
509 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
512 -- | Create an VHDL port -> signal association
513 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
514 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
515 mkAssocElem Nothing _ = Nothing
517 -- | The VHDL Bit type
518 bit_ty :: AST.TypeMark
519 bit_ty = AST.unsafeVHDLBasicId "Bit"
521 -- | The VHDL Boolean type
522 bool_ty :: AST.TypeMark
523 bool_ty = AST.unsafeVHDLBasicId "Boolean"
525 -- | The VHDL std_logic
526 std_logic_ty :: AST.TypeMark
527 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
529 -- Translate a Haskell type to a VHDL type
530 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
532 typemap <- getA vsTypes
533 let builtin_ty = do -- See if this is a tycon and lookup its name
534 (tycon, args) <- Type.splitTyConApp_maybe ty
535 let name = Name.getOccString (TyCon.tyConName tycon)
536 Map.lookup name builtin_types
537 -- If not a builtin type, try the custom types
538 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
539 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
540 -- Found a type, return it
542 -- No type yet, try to construct it
544 newty_maybe <- (construct_vhdl_ty ty)
546 Just (ty_id, ty_def) -> do
547 -- TODO: Check name uniqueness
548 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
550 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
552 -- Construct a new VHDL type for the given Haskell type.
553 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
554 construct_vhdl_ty ty = do
555 case Type.splitTyConApp_maybe ty of
556 Just (tycon, args) -> do
557 let name = Name.getOccString (TyCon.tyConName tycon)
560 res <- mk_vector_ty (tfvec_len ty) ty
563 res <- mk_vector_ty (sized_word_len ty) ty
565 -- Create a custom type from this tycon
566 otherwise -> mk_tycon_ty tycon args
567 Nothing -> return $ Nothing
569 -- | Create VHDL type for a custom tycon
570 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, AST.TypeDef))
571 mk_tycon_ty tycon args =
572 case TyCon.tyConDataCons tycon of
573 -- Not an algebraic type
574 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
576 let arg_tys = DataCon.dataConRepArgTys dc
577 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
578 -- violation? Or does it only mean not to apply it again to the same
580 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
581 elem_tys <- mapM vhdl_ty real_arg_tys
582 let elems = zipWith AST.ElementDec recordlabels elem_tys
583 -- For a single construct datatype, build a record with one field for
585 -- TODO: Add argument type ids to this, to ensure uniqueness
586 -- TODO: Special handling for tuples?
587 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
588 let ty_def = AST.TDR $ AST.RecordTypeDef elems
589 return $ Just (ty_id, ty_def)
590 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
592 -- Create a subst that instantiates all types passed to the tycon
593 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
594 -- to work so far, though..
595 tyvars = TyCon.tyConTyVars tycon
596 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
598 -- | Create a VHDL vector type
600 Int -- ^ The length of the vector
601 -> Type.Type -- ^ The Haskell type to create a VHDL type for
602 -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
604 mk_vector_ty len ty = do
605 -- Assume there is a single type argument
606 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
608 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
609 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
610 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
611 return (ty_id, ty_def)
616 ("Bit", std_logic_ty),
617 ("Bool", bool_ty) -- TysWiredIn.boolTy
621 -- Can only contain alphanumerics and underscores. The supplied string must be
622 -- a valid basic id, otherwise an error value is returned. This function is
623 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
625 mkVHDLBasicId :: String -> AST.VHDLId
627 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
629 -- Strip invalid characters.
630 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
631 -- Strip leading numbers and underscores
632 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
633 -- Strip multiple adjacent underscores
634 strip_multiscore = concat . map (\cs ->
640 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
641 -- different characters than basic ids, but can never be used to refer to
643 -- Use extended Ids for any values that are taken from the source file.
644 mkVHDLExtId :: String -> AST.VHDLId
646 AST.unsafeVHDLExtId $ strip_invalid s
648 -- Allowed characters, taken from ForSyde's mkVHDLExtId
649 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
650 strip_invalid = filter (`elem` allowed)
652 -- Creates a VHDL Id from a binder
657 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
659 -- Extracts the binder name as a String
664 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
666 -- Extracts the string version of the name
667 nameToString :: Name.Name -> String
668 nameToString = OccName.occNameString . Name.nameOccName
670 -- | A consise representation of a (set of) ports on a builtin function
671 --type PortMap = HsValueMap (String, AST.TypeMark)
672 -- | A consise representation of a builtin function
673 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
675 -- | Translate a list of concise representation of builtin functions to a
677 mkBuiltins :: [BuiltIn] -> SignatureMap
678 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
680 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
683 builtin_hsfuncs = Map.keys builtin_funcs
684 builtin_funcs = mkBuiltins
686 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
687 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
688 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
689 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
692 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
694 -- | Map a port specification of a builtin function to a VHDL Signal to put in
696 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
697 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)