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 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)
64 vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
66 AST.Library $ mkVHDLBasicId "IEEE",
67 mkUseAll ["IEEE", "std_logic_1164"],
68 mkUseAll ["IEEE", "numeric_std"]
71 mkUseAll ["work", "types"]
73 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (vec_decls ++ ty_decls ++ subProgSpecs)
74 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
75 subProgSpecs = concat (map subProgSpec tyfun_decls)
76 subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
77 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
78 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
79 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
81 -- Create a use foo.bar.all statement. Takes a list of components in the used
82 -- name. Must contain at least two components
83 mkUseAll :: [String] -> AST.ContextItem
85 AST.Use $ from AST.:.: AST.All
87 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
88 from = foldl select base_prefix (tail ss)
89 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
92 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
93 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
95 createLibraryUnits binds = do
96 entities <- Monad.mapM createEntity binds
97 archs <- Monad.mapM createArchitecture binds
100 let AST.EntityDec id _ = ent in
101 (id, [AST.LUEntity ent, AST.LUArch arch])
105 -- | Create an entity for a given function
107 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
108 -> VHDLState AST.EntityDec -- | The resulting entity
110 createEntity (fname, expr) = do
111 -- Strip off lambda's, these will be arguments
112 let (args, letexpr) = CoreSyn.collectBinders expr
113 args' <- Monad.mapM mkMap args
114 -- There must be a let at top level
115 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
117 let ent_decl' = createEntityAST fname args' res'
118 let AST.EntityDec entity_id _ = ent_decl'
119 let signature = Entity entity_id args' res'
120 modA vsSignatures (Map.insert (bndrToString fname) signature)
124 --[(SignalId, SignalInfo)]
126 -> VHDLState VHDLSignalMapElement
127 -- We only need the vsTypes element from the state
130 --info = Maybe.fromMaybe
131 -- (error $ "Signal not found in the name map? This should not happen!")
132 -- (lookup id sigmap)
133 -- Assume the bndr has a valid VHDL id already
134 id = bndrToVHDLId bndr
135 ty = Var.varType bndr
137 if True -- isPortSigUse $ sigUse info
139 type_mark <- vhdl_ty ty
140 return $ Just (id, type_mark)
145 -- | Create the VHDL AST for an entity
147 CoreSyn.CoreBndr -- | The name of the function
148 -> [VHDLSignalMapElement] -- | The entity's arguments
149 -> VHDLSignalMapElement -- | The entity's result
150 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
152 createEntityAST name args res =
153 AST.EntityDec vhdl_id ports
155 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
156 vhdl_id = mkVHDLBasicId $ bndrToString name
157 ports = Maybe.catMaybes $
158 map (mkIfaceSigDec AST.In) args
159 ++ [mkIfaceSigDec AST.Out res]
161 -- Add a clk port if we have state
162 clk_port = if True -- hasState hsfunc
164 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
168 -- | Create a port declaration
170 AST.Mode -- | The mode for the port (In / Out)
171 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
172 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
174 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
175 mkIfaceSigDec _ Nothing = Nothing
177 -- | Generate a VHDL entity name for the given hsfunc
179 -- TODO: This doesn't work for functions with multiple signatures!
180 -- Use a Basic Id, since using extended id's for entities throws off
181 -- precision and causes problems when generating filenames.
182 mkVHDLBasicId $ hsFuncName hsfunc
184 -- | Create an architecture for a given function
185 createArchitecture ::
186 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
187 -> VHDLState AST.ArchBody -- ^ The architecture for this function
189 createArchitecture (fname, expr) = do
190 --signaturemap <- getA vsSignatures
191 --let signature = Maybe.fromMaybe
192 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
193 -- (Map.lookup hsfunc signaturemap)
194 let entity_id = mkVHDLBasicId $ bndrToString fname
195 -- Strip off lambda's, these will be arguments
196 let (args, letexpr) = CoreSyn.collectBinders expr
197 -- There must be a let at top level
198 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
200 -- Create signal declarations for all internal and state signals
201 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
202 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
204 statements <- Monad.mapM mkConcSm binds
205 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
207 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
208 procs' = map AST.CSPSm procs
209 -- mkSigDec only uses vsTypes from the state
212 -- | Looks up all pairs of old state, new state signals, together with
213 -- the state id they represent.
214 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
215 makeStatePairs flatfunc =
216 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
217 | old_info <- map snd (flat_sigs flatfunc)
218 , new_info <- map snd (flat_sigs flatfunc)
219 -- old_info must be an old state (and, because of the next equality,
220 -- new_info must be a new state).
221 , Maybe.isJust $ oldStateId $ sigUse old_info
222 -- And the state numbers must match
223 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
225 -- Replace the second tuple element with the corresponding SignalInfo
226 --args_states = map (Arrow.second $ signalInfo sigs) args
227 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
228 mkStateProcSm (num, old, new) =
229 AST.ProcSm label [clk] [statement]
231 label = mkVHDLExtId $ "state_" ++ (show num)
232 clk = mkVHDLExtId "clk"
233 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
234 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
235 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
236 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
237 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
239 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
241 if True then do --isInternalSigUse use || isStateSigUse use then do
242 type_mark <- vhdl_ty $ Var.varType bndr
243 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
247 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
249 getSignalId :: SignalInfo -> AST.VHDLId
251 mkVHDLExtId $ Maybe.fromMaybe
252 (error $ "Unnamed signal? This should not happen!")
255 -- | Transforms a core binding into a VHDL concurrent statement
257 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
258 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
260 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
261 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
262 case Var.globalIdVarDetails f of
263 IdInfo.DataConWorkId dc ->
264 -- It's a datacon. Create a record from its arguments.
265 -- First, filter out type args. TODO: Is this the best way to do this?
266 -- The types should already have been taken into acocunt when creating
267 -- the signal, so this should probably work...
268 let valargs = filter isValArg args in
269 if all is_var valargs then do
270 labels <- getFieldLabels (CoreUtils.exprType app)
271 let assigns = zipWith mkassign labels valargs
272 let block_id = bndrToVHDLId bndr
273 let block = AST.BlockSm block_id [] (AST.PMapAspect []) [] assigns
274 return $ AST.CSBSm block
276 error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
278 mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
279 mkassign label (Var arg) =
280 let sel_name = mkSelectedName bndr label in
281 mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
282 IdInfo.VanillaGlobal -> do
283 -- It's a global value imported from elsewhere. These can be builtin
285 funSignatures <- getA vsNameTable
286 case (Map.lookup (bndrToString f) funSignatures) of
287 Just (arg_count, builder) ->
288 if length args == arg_count then
290 sigs = map (bndrToString.varBndr) args
291 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
292 func = builder sigsNames
293 src_wform = AST.Wform [AST.WformElem func Nothing]
294 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
295 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
297 return $ AST.CSSASm assign
299 error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString args
300 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
301 IdInfo.NotGlobalId -> do
302 signatures <- getA vsSignatures
303 -- This is a local id, so it should be a function whose definition we
304 -- have and which can be turned into a component instantiation.
306 signature = Maybe.fromMaybe
307 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
308 (Map.lookup (bndrToString f) signatures)
309 entity_id = ent_id signature
310 label = bndrToString bndr
311 -- Add a clk port if we have state
312 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
313 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
314 portmaps = mkAssocElems args bndr signature
316 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
317 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
319 -- GHC generates some funny "r = r" bindings in let statements before
320 -- simplification. This outputs some dummy ConcSM for these, so things will at
321 -- least compile for now.
322 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
324 -- A single alt case must be a selector. This means thee scrutinee is a simple
325 -- variable, the alternative is a dataalt with a single non-wild binder that
327 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
329 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
330 case List.elemIndex sel_bndr bndrs of
332 labels <- getFieldLabels (Id.idType scrut)
333 let label = labels!!i
334 let sel_name = mkSelectedName scrut label
335 let sel_expr = AST.PrimName sel_name
336 return $ mkUncondAssign (Left bndr) sel_expr
337 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
339 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
341 -- Multiple case alt are be conditional assignments and have only wild
342 -- binders in the alts and only variables in the case values and a variable
343 -- for a scrutinee. We check the constructor of the second alt, since the
344 -- first is the default case, if there is any.
345 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
347 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
348 true_expr = (varToVHDLExpr true)
349 false_expr = (varToVHDLExpr false)
351 return $ mkCondAssign (Left bndr) cond_expr true_expr false_expr
352 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
353 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
354 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
356 -- Create an unconditional assignment statement
358 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
359 -> AST.Expr -- ^ The expression to assign
360 -> AST.ConcSm -- ^ The resulting concurrent statement
361 mkUncondAssign dst expr = mkAssign dst Nothing expr
363 -- Create a conditional assignment statement
365 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
366 -> AST.Expr -- ^ The condition
367 -> AST.Expr -- ^ The value when true
368 -> AST.Expr -- ^ The value when false
369 -> AST.ConcSm -- ^ The resulting concurrent statement
370 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
372 -- Create a conditional or unconditional assignment statement
374 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
375 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
376 -- and the value to assign when true.
377 AST.Expr -> -- ^ The value to assign when false or no condition
378 AST.ConcSm -- ^ The resulting concurrent statement
380 mkAssign dst cond false_expr =
382 -- I'm not 100% how this assignment AST works, but this gets us what we
384 whenelse = case cond of
385 Just (cond_expr, true_expr) ->
387 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
389 [AST.WhenElse true_wform cond_expr]
391 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
392 dst_name = case dst of
393 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
395 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
399 -- Create a record field selector that selects the given label from the record
400 -- stored in the given binder.
401 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
402 mkSelectedName bndr label =
404 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
405 sel_suffix = AST.SSimple $ label
407 AST.NSelected $ sel_prefix AST.:.: sel_suffix
409 -- Finds the field labels for VHDL type generated for the given Core type,
410 -- which must result in a record type.
411 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
412 getFieldLabels ty = do
413 -- Ensure that the type is generated (but throw away it's VHDLId)
415 -- Get the types map, lookup and unpack the VHDL TypeDef
416 types <- getA vsTypes
417 case Map.lookup (OrdType ty) types of
418 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
419 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
421 -- Turn a variable reference into a AST expression
422 varToVHDLExpr :: Var.Var -> AST.Expr
423 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
425 -- Turn a constructor into an AST expression. For dataconstructors, this is
426 -- only the constructor itself, not any arguments it has. Should not be called
427 -- with a DEFAULT constructor.
428 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
429 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
431 tycon = DataCon.dataConTyCon dc
432 tyname = TyCon.tyConName tycon
433 dcname = DataCon.dataConName dc
434 lit = case Name.getOccString tyname of
435 -- TODO: Do something more robust than string matching
436 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
437 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
438 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
439 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
444 mkConcSm sigs (UncondDef src dst) _ = do
445 src_expr <- vhdl_expr src
446 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
447 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
448 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
449 return $ AST.CSSASm assign
451 vhdl_expr (Left id) = return $ mkIdExpr sigs id
452 vhdl_expr (Right expr) =
455 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
456 (Literal lit Nothing) ->
457 return $ AST.PrimLit lit
458 (Literal lit (Just ty)) -> do
459 -- Create a cast expression, which is just a function call using the
460 -- type name as the function name.
461 let litexpr = AST.PrimLit lit
463 let ty_name = AST.NSimple ty_id
464 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
465 return $ AST.PrimFCall $ AST.FCall ty_name args
467 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
469 mkConcSm sigs (CondDef cond true false dst) _ =
471 cond_expr = mkIdExpr sigs cond
472 true_expr = mkIdExpr sigs true
473 false_expr = mkIdExpr sigs false
474 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
475 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
476 whenelse = AST.WhenElse true_wform cond_expr
477 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
478 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
480 return $ AST.CSSASm assign
482 -- | Turn a SignalId into a VHDL Expr
483 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
485 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
486 AST.PrimName src_name
489 [CoreSyn.CoreExpr] -- | The argument that are applied to function
490 -> CoreSyn.CoreBndr -- | The binder in which to store the result
491 -> Entity -- | The entity to map against.
492 -> [AST.AssocElem] -- | The resulting port maps
494 mkAssocElems args res entity =
495 -- Create the actual AssocElems
496 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
498 -- Turn the ports and signals from a map into a flat list. This works,
499 -- since the maps must have an identical form by definition. TODO: Check
501 arg_ports = ent_args entity
502 res_port = ent_res entity
503 -- Extract the id part from the (id, type) tuple
504 ports = map (Monad.liftM fst) (res_port : arg_ports)
505 -- Translate signal numbers into names
506 sigs = (bndrToString res : map (bndrToString.varBndr) args)
508 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
509 -- simple Var CoreExprs, not complexer ones.
510 varBndr :: CoreSyn.CoreExpr -> Var.Id
511 varBndr (CoreSyn.Var id) = id
513 -- | Look up a signal in the signal name map
514 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
515 lookupSigName sigs sig = name
517 info = Maybe.fromMaybe
518 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
520 name = Maybe.fromMaybe
521 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
524 -- | Create an VHDL port -> signal association
525 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
526 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
527 mkAssocElem Nothing _ = Nothing
529 -- | The VHDL Bit type
530 bit_ty :: AST.TypeMark
531 bit_ty = AST.unsafeVHDLBasicId "Bit"
533 -- | The VHDL Boolean type
534 bool_ty :: AST.TypeMark
535 bool_ty = AST.unsafeVHDLBasicId "Boolean"
537 -- | The VHDL std_logic
538 std_logic_ty :: AST.TypeMark
539 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
541 -- Translate a Haskell type to a VHDL type
542 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
544 typemap <- getA vsTypes
545 let builtin_ty = do -- See if this is a tycon and lookup its name
546 (tycon, args) <- Type.splitTyConApp_maybe ty
547 let name = Name.getOccString (TyCon.tyConName tycon)
548 Map.lookup name builtin_types
549 -- If not a builtin type, try the custom types
550 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
551 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
552 -- Found a type, return it
554 -- No type yet, try to construct it
556 newty_maybe <- (construct_vhdl_ty ty)
558 Just (ty_id, ty_def) -> do
559 -- TODO: Check name uniqueness
560 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
562 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
564 -- Construct a new VHDL type for the given Haskell type.
565 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
566 construct_vhdl_ty ty = do
567 case Type.splitTyConApp_maybe ty of
568 Just (tycon, args) -> do
569 let name = Name.getOccString (TyCon.tyConName tycon)
572 res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty) ty
573 return $ Just $ (Arrow.second Right) res
575 -- res <- mk_vector_ty (sized_word_len ty) ty
576 -- return $ Just $ (Arrow.second Left) res
578 res <- mk_natural_ty 0 (ranged_word_bound ty) ty
579 return $ Just $ (Arrow.second Right) res
580 -- Create a custom type from this tycon
581 otherwise -> mk_tycon_ty tycon args
582 Nothing -> return $ Nothing
584 -- | Create VHDL type for a custom tycon
585 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
586 mk_tycon_ty tycon args =
587 case TyCon.tyConDataCons tycon of
588 -- Not an algebraic type
589 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
591 let arg_tys = DataCon.dataConRepArgTys dc
592 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
593 -- violation? Or does it only mean not to apply it again to the same
595 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
596 elem_tys <- mapM vhdl_ty real_arg_tys
597 let elems = zipWith AST.ElementDec recordlabels elem_tys
598 -- For a single construct datatype, build a record with one field for
600 -- TODO: Add argument type ids to this, to ensure uniqueness
601 -- TODO: Special handling for tuples?
602 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
603 let ty_def = AST.TDR $ AST.RecordTypeDef elems
604 return $ Just (ty_id, Left ty_def)
605 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
607 -- Create a subst that instantiates all types passed to the tycon
608 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
609 -- to work so far, though..
610 tyvars = TyCon.tyConTyVars tycon
611 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
613 -- | Create a VHDL vector type
615 Int -- ^ The length of the vector
616 -> Type.Type -- ^ The Haskell element type of the Vector
617 -> Type.Type -- ^ The Haskell type to create a VHDL type for
618 -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
620 mk_vector_ty len el_ty ty = do
621 elem_types_map <- getA vsElemTypes
622 el_ty_tm <- vhdl_ty el_ty
623 let ty_id = mkVHDLExtId $ "vector_0_to_" ++ (show len) ++ "-" ++ (show el_ty_tm)
624 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
625 let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
626 case existing_elem_ty of
628 let ty_def = AST.SubtypeIn t (Just range)
629 return (ty_id, ty_def)
631 let vec_id = mkVHDLExtId $ "vector_" ++ (show el_ty_tm)
632 let vec_def = AST.TDA $ AST.UnconsArrayDef [naturalTM] el_ty_tm
633 modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
634 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns el_ty_tm vec_id))
635 let ty_def = AST.SubtypeIn vec_id (Just range)
636 return (ty_id, ty_def)
639 Int -- ^ The minimum bound (> 0)
640 -> Int -- ^ The maximum bound (> minimum bound)
641 -> Type.Type -- ^ The Haskell type to create a VHDL type for
642 -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
643 mk_natural_ty min_bound max_bound ty = do
644 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
645 let ty_def = AST.SubtypeIn naturalTM (Nothing)
646 return (ty_id, ty_def)
651 ("Bit", std_logic_ty),
652 ("Bool", bool_ty) -- TysWiredIn.boolTy
656 -- Can only contain alphanumerics and underscores. The supplied string must be
657 -- a valid basic id, otherwise an error value is returned. This function is
658 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
660 mkVHDLBasicId :: String -> AST.VHDLId
662 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
664 -- Strip invalid characters.
665 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
666 -- Strip leading numbers and underscores
667 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
668 -- Strip multiple adjacent underscores
669 strip_multiscore = concat . map (\cs ->
675 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
676 -- different characters than basic ids, but can never be used to refer to
678 -- Use extended Ids for any values that are taken from the source file.
679 mkVHDLExtId :: String -> AST.VHDLId
681 AST.unsafeVHDLExtId $ strip_invalid s
683 -- Allowed characters, taken from ForSyde's mkVHDLExtId
684 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
685 strip_invalid = filter (`elem` allowed)
687 -- Creates a VHDL Id from a binder
692 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
694 -- Extracts the binder name as a String
699 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
701 -- Extracts the string version of the name
702 nameToString :: Name.Name -> String
703 nameToString = OccName.occNameString . Name.nameOccName
705 -- | A consise representation of a (set of) ports on a builtin function
706 --type PortMap = HsValueMap (String, AST.TypeMark)
707 -- | A consise representation of a builtin function
708 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
710 -- | Translate a list of concise representation of builtin functions to a
712 mkBuiltins :: [BuiltIn] -> SignatureMap
713 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
715 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
718 builtin_hsfuncs = Map.keys builtin_funcs
719 builtin_funcs = mkBuiltins
721 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
722 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
723 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
724 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
727 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
729 -- | Map a port specification of a builtin function to a VHDL Signal to put in
731 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
732 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)