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_dec, type_package_body]) :
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 tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
63 ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
65 AST.Library $ mkVHDLBasicId "IEEE",
66 mkUseAll ["IEEE", "std_logic_1164"],
67 mkUseAll ["IEEE", "numeric_std"]
70 mkUseAll ["work", "types"]
72 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (ty_decls ++ subProgSpecs)
73 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
74 subProgSpecs = concat (map subProgSpec tyfun_decls)
75 subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
76 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
77 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
78 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
80 -- Create a use foo.bar.all statement. Takes a list of components in the used
81 -- name. Must contain at least two components
82 mkUseAll :: [String] -> AST.ContextItem
84 AST.Use $ from AST.:.: AST.All
86 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
87 from = foldl select base_prefix (tail ss)
88 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
91 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
92 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
94 createLibraryUnits binds = do
95 entities <- Monad.mapM createEntity binds
96 archs <- Monad.mapM createArchitecture binds
99 let AST.EntityDec id _ = ent in
100 (id, [AST.LUEntity ent, AST.LUArch arch])
104 -- | Create an entity for a given function
106 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
107 -> VHDLState AST.EntityDec -- | The resulting entity
109 createEntity (fname, expr) = do
110 -- Strip off lambda's, these will be arguments
111 let (args, letexpr) = CoreSyn.collectBinders expr
112 args' <- Monad.mapM mkMap args
113 -- There must be a let at top level
114 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
116 let ent_decl' = createEntityAST fname args' res'
117 let AST.EntityDec entity_id _ = ent_decl'
118 let signature = Entity entity_id args' res'
119 modA vsSignatures (Map.insert (bndrToString fname) signature)
123 --[(SignalId, SignalInfo)]
125 -> VHDLState VHDLSignalMapElement
126 -- We only need the vsTypes element from the state
129 --info = Maybe.fromMaybe
130 -- (error $ "Signal not found in the name map? This should not happen!")
131 -- (lookup id sigmap)
132 -- Assume the bndr has a valid VHDL id already
133 id = bndrToVHDLId bndr
134 ty = Var.varType bndr
136 if True -- isPortSigUse $ sigUse info
138 type_mark <- vhdl_ty ty
139 return $ Just (id, type_mark)
144 -- | Create the VHDL AST for an entity
146 CoreSyn.CoreBndr -- | The name of the function
147 -> [VHDLSignalMapElement] -- | The entity's arguments
148 -> VHDLSignalMapElement -- | The entity's result
149 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
151 createEntityAST name args res =
152 AST.EntityDec vhdl_id ports
154 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
155 vhdl_id = mkVHDLBasicId $ bndrToString name
156 ports = Maybe.catMaybes $
157 map (mkIfaceSigDec AST.In) args
158 ++ [mkIfaceSigDec AST.Out res]
160 -- Add a clk port if we have state
161 clk_port = if True -- hasState hsfunc
163 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
167 -- | Create a port declaration
169 AST.Mode -- | The mode for the port (In / Out)
170 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
171 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
173 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
174 mkIfaceSigDec _ Nothing = Nothing
176 -- | Generate a VHDL entity name for the given hsfunc
178 -- TODO: This doesn't work for functions with multiple signatures!
179 -- Use a Basic Id, since using extended id's for entities throws off
180 -- precision and causes problems when generating filenames.
181 mkVHDLBasicId $ hsFuncName hsfunc
183 -- | Create an architecture for a given function
184 createArchitecture ::
185 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
186 -> VHDLState AST.ArchBody -- ^ The architecture for this function
188 createArchitecture (fname, expr) = do
189 --signaturemap <- getA vsSignatures
190 --let signature = Maybe.fromMaybe
191 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
192 -- (Map.lookup hsfunc signaturemap)
193 let entity_id = mkVHDLBasicId $ bndrToString fname
194 -- Strip off lambda's, these will be arguments
195 let (args, letexpr) = CoreSyn.collectBinders expr
196 -- There must be a let at top level
197 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
199 -- Create signal declarations for all internal and state signals
200 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
201 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
203 statements <- Monad.mapM mkConcSm binds
204 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
206 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
207 procs' = map AST.CSPSm procs
208 -- mkSigDec only uses vsTypes from the state
211 -- | Looks up all pairs of old state, new state signals, together with
212 -- the state id they represent.
213 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
214 makeStatePairs flatfunc =
215 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
216 | old_info <- map snd (flat_sigs flatfunc)
217 , new_info <- map snd (flat_sigs flatfunc)
218 -- old_info must be an old state (and, because of the next equality,
219 -- new_info must be a new state).
220 , Maybe.isJust $ oldStateId $ sigUse old_info
221 -- And the state numbers must match
222 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
224 -- Replace the second tuple element with the corresponding SignalInfo
225 --args_states = map (Arrow.second $ signalInfo sigs) args
226 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
227 mkStateProcSm (num, old, new) =
228 AST.ProcSm label [clk] [statement]
230 label = mkVHDLExtId $ "state_" ++ (show num)
231 clk = mkVHDLExtId "clk"
232 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
233 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
234 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
235 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
236 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
238 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
240 if True then do --isInternalSigUse use || isStateSigUse use then do
241 type_mark <- vhdl_ty $ Var.varType bndr
242 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
246 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
248 getSignalId :: SignalInfo -> AST.VHDLId
250 mkVHDLExtId $ Maybe.fromMaybe
251 (error $ "Unnamed signal? This should not happen!")
254 -- | Transforms a core binding into a VHDL concurrent statement
256 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
257 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
259 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
260 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
261 case Var.globalIdVarDetails f of
262 IdInfo.DataConWorkId dc ->
263 -- It's a datacon. Create a record from its arguments.
264 -- First, filter out type args. TODO: Is this the best way to do this?
265 -- The types should already have been taken into acocunt when creating
266 -- the signal, so this should probably work...
267 let valargs = filter isValArg args in
268 if all is_var valargs then do
269 labels <- getFieldLabels (CoreUtils.exprType app)
270 let assigns = zipWith mkassign labels valargs
271 let block_id = bndrToVHDLId bndr
272 let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
273 return $ AST.CSBSm block
275 error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
277 mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
278 mkassign label (Var arg) =
279 let sel_name = mkSelectedName bndr label in
280 mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
281 IdInfo.VanillaGlobal -> do
282 -- It's a global value imported from elsewhere. These can be builtin
284 funSignatures <- getA vsNameTable
285 case (Map.lookup (bndrToString f) funSignatures) of
288 sigs = map (bndrToString.varBndr) args
289 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
290 func = (snd funSignature) sigsNames
291 src_wform = AST.Wform [AST.WformElem func Nothing]
292 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
293 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
295 return $ AST.CSSASm assign
296 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
297 IdInfo.NotGlobalId -> do
298 signatures <- getA vsSignatures
299 -- This is a local id, so it should be a function whose definition we
300 -- have and which can be turned into a component instantiation.
302 signature = Maybe.fromMaybe
303 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
304 (Map.lookup (bndrToString f) signatures)
305 entity_id = ent_id signature
306 label = bndrToString bndr
307 -- Add a clk port if we have state
308 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
309 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
310 portmaps = mkAssocElems args bndr signature
312 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
313 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
315 -- GHC generates some funny "r = r" bindings in let statements before
316 -- simplification. This outputs some dummy ConcSM for these, so things will at
317 -- least compile for now.
318 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
320 -- A single alt case must be a selector. This means thee scrutinee is a simple
321 -- variable, the alternative is a dataalt with a single non-wild binder that
323 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
325 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
326 case List.elemIndex sel_bndr bndrs of
328 labels <- getFieldLabels (Id.idType scrut)
329 let label = labels!!i
330 let sel_name = mkSelectedName scrut label
331 let sel_expr = AST.PrimName sel_name
332 return $ mkUncondAssign (Left bndr) sel_expr
333 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
335 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
337 -- Multiple case alt are be conditional assignments and have only wild
338 -- binders in the alts and only variables in the case values and a variable
339 -- for a scrutinee. We check the constructor of the second alt, since the
340 -- first is the default case, if there is any.
341 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
343 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
344 true_expr = (varToVHDLExpr true)
345 false_expr = (varToVHDLExpr false)
347 return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
348 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
349 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
351 -- Create an unconditional assignment statement
353 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
354 -> AST.Expr -- ^ The expression to assign
355 -> AST.ConcSm -- ^ The resulting concurrent statement
356 mkUncondAssign dst expr = mkAssign dst Nothing expr
358 -- Create a conditional assignment statement
360 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
361 -> AST.Expr -- ^ The condition
362 -> AST.Expr -- ^ The value when true
363 -> AST.Expr -- ^ The value when false
364 -> AST.ConcSm -- ^ The resulting concurrent statement
365 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
367 -- Create a conditional or unconditional assignment statement
369 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
370 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
371 -- and the value to assign when true.
372 AST.Expr -> -- ^ The value to assign when false or no condition
373 AST.ConcSm -- ^ The resulting concurrent statement
375 mkAssign dst cond false_expr =
377 -- I'm not 100% how this assignment AST works, but this gets us what we
379 whenelse = case cond of
380 Just (cond_expr, true_expr) ->
382 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
384 [AST.WhenElse true_wform cond_expr]
386 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
387 dst_name = case dst of
388 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
390 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
394 -- Create a record field selector that selects the given label from the record
395 -- stored in the given binder.
396 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
397 mkSelectedName bndr label =
399 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
400 sel_suffix = AST.SSimple $ label
402 AST.NSelected $ sel_prefix AST.:.: sel_suffix
404 -- Finds the field labels for VHDL type generated for the given Core type,
405 -- which must result in a record type.
406 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
407 getFieldLabels ty = do
408 -- Ensure that the type is generated (but throw away it's VHDLId)
410 -- Get the types map, lookup and unpack the VHDL TypeDef
411 types <- getA vsTypes
412 case Map.lookup (OrdType ty) types of
413 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
414 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
416 -- Turn a variable reference into a AST expression
417 varToVHDLExpr :: Var.Var -> AST.Expr
418 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
420 -- Turn a constructor into an AST expression. For dataconstructors, this is
421 -- only the constructor itself, not any arguments it has. Should not be called
422 -- with a DEFAULT constructor.
423 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
424 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
426 tycon = DataCon.dataConTyCon dc
427 tyname = TyCon.tyConName tycon
428 dcname = DataCon.dataConName dc
429 lit = case Name.getOccString tyname of
430 -- TODO: Do something more robust than string matching
431 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
432 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
433 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
434 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
439 mkConcSm sigs (UncondDef src dst) _ = do
440 src_expr <- vhdl_expr src
441 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
442 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
443 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
444 return $ AST.CSSASm assign
446 vhdl_expr (Left id) = return $ mkIdExpr sigs id
447 vhdl_expr (Right expr) =
450 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
451 (Literal lit Nothing) ->
452 return $ AST.PrimLit lit
453 (Literal lit (Just ty)) -> do
454 -- Create a cast expression, which is just a function call using the
455 -- type name as the function name.
456 let litexpr = AST.PrimLit lit
458 let ty_name = AST.NSimple ty_id
459 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
460 return $ AST.PrimFCall $ AST.FCall ty_name args
462 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
464 mkConcSm sigs (CondDef cond true false dst) _ =
466 cond_expr = mkIdExpr sigs cond
467 true_expr = mkIdExpr sigs true
468 false_expr = mkIdExpr sigs false
469 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
470 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
471 whenelse = AST.WhenElse true_wform cond_expr
472 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
473 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
475 return $ AST.CSSASm assign
477 -- | Turn a SignalId into a VHDL Expr
478 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
480 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
481 AST.PrimName src_name
484 [CoreSyn.CoreExpr] -- | The argument that are applied to function
485 -> CoreSyn.CoreBndr -- | The binder in which to store the result
486 -> Entity -- | The entity to map against.
487 -> [AST.AssocElem] -- | The resulting port maps
489 mkAssocElems args res entity =
490 -- Create the actual AssocElems
491 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
493 -- Turn the ports and signals from a map into a flat list. This works,
494 -- since the maps must have an identical form by definition. TODO: Check
496 arg_ports = ent_args entity
497 res_port = ent_res entity
498 -- Extract the id part from the (id, type) tuple
499 ports = map (Monad.liftM fst) (res_port : arg_ports)
500 -- Translate signal numbers into names
501 sigs = (bndrToString res : map (bndrToString.varBndr) args)
503 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
504 -- simple Var CoreExprs, not complexer ones.
505 varBndr :: CoreSyn.CoreExpr -> Var.Id
506 varBndr (CoreSyn.Var id) = id
508 -- | Look up a signal in the signal name map
509 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
510 lookupSigName sigs sig = name
512 info = Maybe.fromMaybe
513 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
515 name = Maybe.fromMaybe
516 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
519 -- | Create an VHDL port -> signal association
520 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
521 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
522 mkAssocElem Nothing _ = Nothing
524 -- | The VHDL Bit type
525 bit_ty :: AST.TypeMark
526 bit_ty = AST.unsafeVHDLBasicId "Bit"
528 -- | The VHDL Boolean type
529 bool_ty :: AST.TypeMark
530 bool_ty = AST.unsafeVHDLBasicId "Boolean"
532 -- | The VHDL std_logic
533 std_logic_ty :: AST.TypeMark
534 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
536 -- Translate a Haskell type to a VHDL type
537 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
539 typemap <- getA vsTypes
540 let builtin_ty = do -- See if this is a tycon and lookup its name
541 (tycon, args) <- Type.splitTyConApp_maybe ty
542 let name = Name.getOccString (TyCon.tyConName tycon)
543 Map.lookup name builtin_types
544 -- If not a builtin type, try the custom types
545 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
546 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
547 -- Found a type, return it
549 -- No type yet, try to construct it
551 newty_maybe <- (construct_vhdl_ty ty)
553 Just (ty_id, ty_def) -> do
554 -- TODO: Check name uniqueness
555 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
557 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
559 -- Construct a new VHDL type for the given Haskell type.
560 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
561 construct_vhdl_ty ty = do
562 case Type.splitTyConApp_maybe ty of
563 Just (tycon, args) -> do
564 let name = Name.getOccString (TyCon.tyConName tycon)
567 res <- mk_vector_ty (tfvec_len ty) ty
568 return $ Just $ (Arrow.second Left) res
570 res <- mk_vector_ty (sized_word_len ty) ty
571 return $ Just $ (Arrow.second Left) res
573 res <- mk_natural_ty 0 (ranged_word_bound ty) ty
574 return $ Just $ (Arrow.second Right) res
575 -- Create a custom type from this tycon
576 otherwise -> mk_tycon_ty tycon args
577 Nothing -> return $ Nothing
579 -- | Create VHDL type for a custom tycon
580 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
581 mk_tycon_ty tycon args =
582 case TyCon.tyConDataCons tycon of
583 -- Not an algebraic type
584 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
586 let arg_tys = DataCon.dataConRepArgTys dc
587 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
588 -- violation? Or does it only mean not to apply it again to the same
590 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
591 elem_tys <- mapM vhdl_ty real_arg_tys
592 let elems = zipWith AST.ElementDec recordlabels elem_tys
593 -- For a single construct datatype, build a record with one field for
595 -- TODO: Add argument type ids to this, to ensure uniqueness
596 -- TODO: Special handling for tuples?
597 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
598 let ty_def = AST.TDR $ AST.RecordTypeDef elems
599 return $ Just (ty_id, Left ty_def)
600 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
602 -- Create a subst that instantiates all types passed to the tycon
603 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
604 -- to work so far, though..
605 tyvars = TyCon.tyConTyVars tycon
606 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
608 -- | Create a VHDL vector type
610 Int -- ^ The length of the vector
611 -> Type.Type -- ^ The Haskell type to create a VHDL type for
612 -> VHDLState (AST.TypeMark, AST.TypeDef) -- The typemark created.
614 mk_vector_ty len ty = do
615 -- Assume there is a single type argument
616 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
618 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
619 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
620 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
621 return (ty_id, ty_def)
624 Int -- ^ The minimum bound (> 0)
625 -> Int -- ^ The maximum bound (> minimum bound)
626 -> Type.Type -- ^ The Haskell type to create a VHDL type for
627 -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
628 mk_natural_ty min_bound max_bound ty = do
629 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
630 let ty_def = AST.SubtypeIn naturalTM (Nothing)
631 return (ty_id, ty_def)
636 ("Bit", std_logic_ty),
637 ("Bool", bool_ty) -- TysWiredIn.boolTy
641 -- Can only contain alphanumerics and underscores. The supplied string must be
642 -- a valid basic id, otherwise an error value is returned. This function is
643 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
645 mkVHDLBasicId :: String -> AST.VHDLId
647 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
649 -- Strip invalid characters.
650 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
651 -- Strip leading numbers and underscores
652 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
653 -- Strip multiple adjacent underscores
654 strip_multiscore = concat . map (\cs ->
660 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
661 -- different characters than basic ids, but can never be used to refer to
663 -- Use extended Ids for any values that are taken from the source file.
664 mkVHDLExtId :: String -> AST.VHDLId
666 AST.unsafeVHDLExtId $ strip_invalid s
668 -- Allowed characters, taken from ForSyde's mkVHDLExtId
669 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
670 strip_invalid = filter (`elem` allowed)
672 -- Creates a VHDL Id from a binder
677 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
679 -- Extracts the binder name as a String
684 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
686 -- Extracts the string version of the name
687 nameToString :: Name.Name -> String
688 nameToString = OccName.occNameString . Name.nameOccName
690 -- | A consise representation of a (set of) ports on a builtin function
691 --type PortMap = HsValueMap (String, AST.TypeMark)
692 -- | A consise representation of a builtin function
693 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
695 -- | Translate a list of concise representation of builtin functions to a
697 mkBuiltins :: [BuiltIn] -> SignatureMap
698 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
700 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
703 builtin_hsfuncs = Map.keys builtin_funcs
704 builtin_funcs = mkBuiltins
706 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
707 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
708 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
709 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
712 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
714 -- | Map a port specification of a builtin function to a VHDL Signal to put in
716 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
717 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)