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 TcType
34 import qualified DataCon
35 import qualified CoreSubst
36 import qualified CoreUtils
37 import Outputable ( showSDoc, ppr )
43 import TranslatorTypes
49 import GlobalNameTable
52 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
53 -> [(AST.VHDLId, AST.DesignFile)]
55 createDesignFiles binds =
56 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) :
57 map (Arrow.second $ AST.DesignFile full_context) units
60 init_session = VHDLSession Map.empty Map.empty Map.empty Map.empty globalNameTable
61 (units, final_session) =
62 State.runState (createLibraryUnits binds) init_session
63 tyfun_decls = Map.elems (final_session ^.vsTypeFuns)
64 ty_decls = map mktydecl $ Map.elems (final_session ^. vsTypes)
65 vec_decls = map (\(v_id, v_def) -> AST.PDITD $ AST.TypeDec v_id v_def) (Map.elems (final_session ^. vsElemTypes))
66 tfvec_index_decl = AST.PDISD $ AST.SubtypeDec tfvec_indexTM tfvec_index_def
67 tfvec_range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit "-1") (AST.PrimName $ AST.NAttribute $ AST.AttribName (AST.NSimple integerTM) highId Nothing)
68 tfvec_index_def = AST.SubtypeIn integerTM (Just tfvec_range)
70 AST.Library $ mkVHDLBasicId "IEEE",
71 mkUseAll ["IEEE", "std_logic_1164"],
72 mkUseAll ["IEEE", "numeric_std"]
75 mkUseAll ["work", "types"]
77 type_package_dec = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") ([tfvec_index_decl] ++ vec_decls ++ ty_decls ++ subProgSpecs)
78 type_package_body = AST.LUPackageBody $ AST.PackageBody typesId (concat tyfun_decls)
79 subProgSpecs = concat (map subProgSpec tyfun_decls)
80 subProgSpec = map (\(AST.SubProgBody spec _ _) -> AST.PDISS spec)
81 mktydecl :: (AST.VHDLId, Either AST.TypeDef AST.SubtypeIn) -> AST.PackageDecItem
82 mktydecl (ty_id, Left ty_def) = AST.PDITD $ AST.TypeDec ty_id ty_def
83 mktydecl (ty_id, Right ty_def) = AST.PDISD $ AST.SubtypeDec ty_id ty_def
85 -- Create a use foo.bar.all statement. Takes a list of components in the used
86 -- name. Must contain at least two components
87 mkUseAll :: [String] -> AST.ContextItem
89 AST.Use $ from AST.:.: AST.All
91 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
92 from = foldl select base_prefix (tail ss)
93 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
96 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
97 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
99 createLibraryUnits binds = do
100 entities <- Monad.mapM createEntity binds
101 archs <- Monad.mapM createArchitecture binds
104 let AST.EntityDec id _ = ent in
105 (id, [AST.LUEntity ent, AST.LUArch arch])
109 -- | Create an entity for a given function
111 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
112 -> VHDLState AST.EntityDec -- | The resulting entity
114 createEntity (fname, expr) = do
115 -- Strip off lambda's, these will be arguments
116 let (args, letexpr) = CoreSyn.collectBinders expr
117 args' <- Monad.mapM mkMap args
118 -- There must be a let at top level
119 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
121 let vhdl_id = mkVHDLBasicId $ bndrToString fname ++ "_" ++ varToStringUniq fname
122 let ent_decl' = createEntityAST vhdl_id args' res'
123 let AST.EntityDec entity_id _ = ent_decl'
124 let signature = Entity entity_id args' res'
125 modA vsSignatures (Map.insert fname signature)
129 --[(SignalId, SignalInfo)]
131 -> VHDLState VHDLSignalMapElement
132 -- We only need the vsTypes element from the state
135 --info = Maybe.fromMaybe
136 -- (error $ "Signal not found in the name map? This should not happen!")
137 -- (lookup id sigmap)
138 -- Assume the bndr has a valid VHDL id already
139 id = bndrToVHDLId bndr
140 ty = Var.varType bndr
142 if True -- isPortSigUse $ sigUse info
144 type_mark <- vhdl_ty ty
145 return $ Just (id, type_mark)
150 -- | Create the VHDL AST for an entity
152 AST.VHDLId -- | The name of the function
153 -> [VHDLSignalMapElement] -- | The entity's arguments
154 -> VHDLSignalMapElement -- | The entity's result
155 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
157 createEntityAST vhdl_id args res =
158 AST.EntityDec vhdl_id ports
160 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
161 ports = Maybe.catMaybes $
162 map (mkIfaceSigDec AST.In) args
163 ++ [mkIfaceSigDec AST.Out res]
165 -- Add a clk port if we have state
166 clk_port = if True -- hasState hsfunc
168 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
172 -- | Create a port declaration
174 AST.Mode -- | The mode for the port (In / Out)
175 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
176 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
178 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
179 mkIfaceSigDec _ Nothing = Nothing
181 -- | Generate a VHDL entity name for the given hsfunc
183 -- TODO: This doesn't work for functions with multiple signatures!
184 -- Use a Basic Id, since using extended id's for entities throws off
185 -- precision and causes problems when generating filenames.
186 mkVHDLBasicId $ hsFuncName hsfunc
188 -- | Create an architecture for a given function
189 createArchitecture ::
190 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
191 -> VHDLState AST.ArchBody -- ^ The architecture for this function
193 createArchitecture (fname, expr) = do
194 signaturemap <- getA vsSignatures
195 let signature = Maybe.fromMaybe
196 (error $ "Generating architecture for function " ++ (pprString fname) ++ "without signature? This should not happen!")
197 (Map.lookup fname signaturemap)
198 let entity_id = ent_id signature
199 -- Strip off lambda's, these will be arguments
200 let (args, letexpr) = CoreSyn.collectBinders expr
201 -- There must be a let at top level
202 let (CoreSyn.Let (CoreSyn.Rec binds) (Var res)) = letexpr
204 -- Create signal declarations for all binders in the let expression, except
205 -- for the output port (that will already have an output port declared in
207 sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
208 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
210 statementss <- Monad.mapM mkConcSm binds
211 let statements = concat statementss
212 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
214 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
215 procs' = map AST.CSPSm procs
216 -- mkSigDec only uses vsTypes from the state
219 -- | Looks up all pairs of old state, new state signals, together with
220 -- the state id they represent.
221 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
222 makeStatePairs flatfunc =
223 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
224 | old_info <- map snd (flat_sigs flatfunc)
225 , new_info <- map snd (flat_sigs flatfunc)
226 -- old_info must be an old state (and, because of the next equality,
227 -- new_info must be a new state).
228 , Maybe.isJust $ oldStateId $ sigUse old_info
229 -- And the state numbers must match
230 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
232 -- Replace the second tuple element with the corresponding SignalInfo
233 --args_states = map (Arrow.second $ signalInfo sigs) args
234 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
235 mkStateProcSm (num, old, new) =
236 AST.ProcSm label [clk] [statement]
238 label = mkVHDLExtId $ "state_" ++ (show num)
239 clk = mkVHDLExtId "clk"
240 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
241 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
242 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
243 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
244 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
246 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
248 if True then do --isInternalSigUse use || isStateSigUse use then do
249 type_mark <- vhdl_ty $ Var.varType bndr
250 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
254 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
256 getSignalId :: SignalInfo -> AST.VHDLId
258 mkVHDLExtId $ Maybe.fromMaybe
259 (error $ "Unnamed signal? This should not happen!")
262 -- | Transforms a core binding into a VHDL concurrent statement
264 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
265 -> VHDLState [AST.ConcSm] -- ^ The corresponding VHDL component instantiations.
268 -- Ignore Cast expressions, they should not longer have any meaning as long as
269 -- the type works out.
270 mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr)
272 -- For simple a = b assignments, just generate an unconditional signal
273 -- assignment. This should only happen for dataconstructors without arguments.
274 -- TODO: Integrate this with the below code for application (essentially this
275 -- is an application without arguments)
276 mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)]
278 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
279 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
280 let valargs' = filter isValArg args
281 let valargs = filter (\(CoreSyn.Var bndr) -> not (Id.isDictId bndr)) valargs'
282 case Var.globalIdVarDetails f of
283 IdInfo.DataConWorkId dc ->
284 -- It's a datacon. Create a record from its arguments.
285 -- First, filter out type args. TODO: Is this the best way to do this?
286 -- The types should already have been taken into acocunt when creating
287 -- the signal, so this should probably work...
288 --let valargs = filter isValArg args in
289 if all is_var valargs then do
290 labels <- getFieldLabels (CoreUtils.exprType app)
291 return $ zipWith mkassign labels valargs
293 error $ "VHDL.mkConcSm Not in normal form: One ore more complex arguments: " ++ pprString args
295 mkassign :: AST.VHDLId -> CoreExpr -> AST.ConcSm
296 mkassign label (Var arg) =
297 let sel_name = mkSelectedName bndr label in
298 mkUncondAssign (Right sel_name) (varToVHDLExpr arg)
299 IdInfo.VanillaGlobal -> do
300 -- It's a global value imported from elsewhere. These can be builtin
302 funSignatures <- getA vsNameTable
303 signatures <- getA vsSignatures
304 case (Map.lookup (bndrToString f) funSignatures) of
305 Just (arg_count, builder) ->
306 if length valargs == arg_count then
310 sigs = map (varToVHDLExpr.varBndr) valargs
311 func = funBuilder sigs
312 src_wform = AST.Wform [AST.WformElem func Nothing]
313 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
314 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
316 return [AST.CSSASm assign]
319 ty = Var.varType bndr
321 sigs = map varBndr valargs
322 signature = Maybe.fromMaybe
323 (error $ "Using function '" ++ (bndrToString (head sigs)) ++ "' without signature? This should not happen!")
324 (Map.lookup (head sigs) signatures)
325 arg_names = map (mkVHDLExtId . bndrToString) (tail sigs)
326 dst_name = mkVHDLExtId (bndrToString bndr)
327 genSm = genBuilder len signature (arg_names ++ [dst_name])
328 in return [AST.CSGSm genSm]
330 error $ "VHDL.mkConcSm Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ pprString valargs
331 Nothing -> error $ "Using function from another module that is not a known builtin: " ++ pprString f
332 IdInfo.NotGlobalId -> do
333 signatures <- getA vsSignatures
334 -- This is a local id, so it should be a function whose definition we
335 -- have and which can be turned into a component instantiation.
337 signature = Maybe.fromMaybe
338 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
339 (Map.lookup f signatures)
340 entity_id = ent_id signature
341 label = "comp_ins_" ++ bndrToString bndr
342 -- Add a clk port if we have state
343 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
344 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
345 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
346 portmaps = clk_port : mkAssocElems args bndr signature
348 return [AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)]
349 details -> error $ "Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
351 -- A single alt case must be a selector. This means thee scrutinee is a simple
352 -- variable, the alternative is a dataalt with a single non-wild binder that
354 mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) =
356 (DataAlt dc, bndrs, (Var sel_bndr)) -> do
357 case List.elemIndex sel_bndr bndrs of
359 labels <- getFieldLabels (Id.idType scrut)
360 let label = labels!!i
361 let sel_name = mkSelectedName scrut label
362 let sel_expr = AST.PrimName sel_name
363 return [mkUncondAssign (Left bndr) sel_expr]
364 Nothing -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
366 _ -> error $ "VHDL.mkConcSM Not in normal form: Not a selector case:\n" ++ (pprString expr)
368 -- Multiple case alt are be conditional assignments and have only wild
369 -- binders in the alts and only variables in the case values and a variable
370 -- for a scrutinee. We check the constructor of the second alt, since the
371 -- first is the default case, if there is any.
372 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
374 cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con)
375 true_expr = (varToVHDLExpr true)
376 false_expr = (varToVHDLExpr false)
378 return [mkCondAssign (Left bndr) cond_expr true_expr false_expr]
379 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
380 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
381 mkConcSm (bndr, expr) = error $ "VHDL.mkConcSM Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
383 -- Create an unconditional assignment statement
385 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
386 -> AST.Expr -- ^ The expression to assign
387 -> AST.ConcSm -- ^ The resulting concurrent statement
388 mkUncondAssign dst expr = mkAssign dst Nothing expr
390 -- Create a conditional assignment statement
392 Either CoreBndr AST.VHDLName -- ^ The signal to assign to
393 -> AST.Expr -- ^ The condition
394 -> AST.Expr -- ^ The value when true
395 -> AST.Expr -- ^ The value when false
396 -> AST.ConcSm -- ^ The resulting concurrent statement
397 mkCondAssign dst cond true false = mkAssign dst (Just (cond, true)) false
399 -- Create a conditional or unconditional assignment statement
401 Either CoreBndr AST.VHDLName -> -- ^ The signal to assign to
402 Maybe (AST.Expr , AST.Expr) -> -- ^ Optionally, the condition to test for
403 -- and the value to assign when true.
404 AST.Expr -> -- ^ The value to assign when false or no condition
405 AST.ConcSm -- ^ The resulting concurrent statement
407 mkAssign dst cond false_expr =
409 -- I'm not 100% how this assignment AST works, but this gets us what we
411 whenelse = case cond of
412 Just (cond_expr, true_expr) ->
414 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
416 [AST.WhenElse true_wform cond_expr]
418 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
419 dst_name = case dst of
420 Left bndr -> AST.NSimple (bndrToVHDLId bndr)
422 assign = dst_name AST.:<==: (AST.ConWforms whenelse false_wform Nothing)
426 -- Create a record field selector that selects the given label from the record
427 -- stored in the given binder.
428 mkSelectedName :: CoreBndr -> AST.VHDLId -> AST.VHDLName
429 mkSelectedName bndr label =
431 sel_prefix = AST.NSimple $ bndrToVHDLId bndr
432 sel_suffix = AST.SSimple $ label
434 AST.NSelected $ sel_prefix AST.:.: sel_suffix
436 -- Finds the field labels for VHDL type generated for the given Core type,
437 -- which must result in a record type.
438 getFieldLabels :: Type.Type -> VHDLState [AST.VHDLId]
439 getFieldLabels ty = do
440 -- Ensure that the type is generated (but throw away it's VHDLId)
442 -- Get the types map, lookup and unpack the VHDL TypeDef
443 types <- getA vsTypes
444 case Map.lookup (OrdType ty) types of
445 Just (_, Left (AST.TDR (AST.RecordTypeDef elems))) -> return $ map (\(AST.ElementDec id _) -> id) elems
446 _ -> error $ "VHDL.getFieldLabels Type not found or not a record type? This should not happen! Type: " ++ (show ty)
448 -- Turn a variable reference into a AST expression
449 varToVHDLExpr :: Var.Var -> AST.Expr
451 case Id.isDataConWorkId_maybe var of
452 Just dc -> dataconToVHDLExpr dc
453 -- This is a dataconstructor.
454 -- Not a datacon, just another signal. Perhaps we should check for
455 -- local/global here as well?
456 Nothing -> AST.PrimName $ AST.NSimple $ bndrToVHDLId var
458 -- Turn a alternative constructor into an AST expression. For
459 -- dataconstructors, this is only the constructor itself, not any arguments it
460 -- has. Should not be called with a DEFAULT constructor.
461 altconToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
462 altconToVHDLExpr (DataAlt dc) = dataconToVHDLExpr dc
464 altconToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
465 altconToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
467 -- Turn a datacon (without arguments!) into a VHDL expression.
468 dataconToVHDLExpr :: DataCon.DataCon -> AST.Expr
469 dataconToVHDLExpr dc = AST.PrimLit lit
471 tycon = DataCon.dataConTyCon dc
472 tyname = TyCon.tyConName tycon
473 dcname = DataCon.dataConName dc
474 lit = case Name.getOccString tyname of
475 -- TODO: Do something more robust than string matching
476 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
477 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
481 mkConcSm sigs (UncondDef src dst) _ = do
482 src_expr <- vhdl_expr src
483 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
484 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
485 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
486 return $ AST.CSSASm assign
488 vhdl_expr (Left id) = return $ mkIdExpr sigs id
489 vhdl_expr (Right expr) =
492 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
493 (Literal lit Nothing) ->
494 return $ AST.PrimLit lit
495 (Literal lit (Just ty)) -> do
496 -- Create a cast expression, which is just a function call using the
497 -- type name as the function name.
498 let litexpr = AST.PrimLit lit
500 let ty_name = AST.NSimple ty_id
501 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
502 return $ AST.PrimFCall $ AST.FCall ty_name args
504 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
506 mkConcSm sigs (CondDef cond true false dst) _ =
508 cond_expr = mkIdExpr sigs cond
509 true_expr = mkIdExpr sigs true
510 false_expr = mkIdExpr sigs false
511 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
512 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
513 whenelse = AST.WhenElse true_wform cond_expr
514 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
515 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
517 return $ AST.CSSASm assign
519 -- | Turn a SignalId into a VHDL Expr
520 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
522 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
523 AST.PrimName src_name
526 [CoreSyn.CoreExpr] -- | The argument that are applied to function
527 -> CoreSyn.CoreBndr -- | The binder in which to store the result
528 -> Entity -- | The entity to map against.
529 -> [AST.AssocElem] -- | The resulting port maps
531 mkAssocElems args res entity =
532 -- Create the actual AssocElems
533 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
535 -- Turn the ports and signals from a map into a flat list. This works,
536 -- since the maps must have an identical form by definition. TODO: Check
538 arg_ports = ent_args entity
539 res_port = ent_res entity
540 -- Extract the id part from the (id, type) tuple
541 ports = map (Monad.liftM fst) (res_port : arg_ports)
542 -- Translate signal numbers into names
543 sigs = (bndrToString res : map (bndrToString.varBndr) args)
545 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
546 -- simple Var CoreExprs, not complexer ones.
547 varBndr :: CoreSyn.CoreExpr -> Var.Id
548 varBndr (CoreSyn.Var id) = id
550 -- | Look up a signal in the signal name map
551 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
552 lookupSigName sigs sig = name
554 info = Maybe.fromMaybe
555 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
557 name = Maybe.fromMaybe
558 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
561 -- | Create an VHDL port -> signal association
562 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
563 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
564 mkAssocElem Nothing _ = Nothing
566 -- | The VHDL Bit type
567 bit_ty :: AST.TypeMark
568 bit_ty = AST.unsafeVHDLBasicId "Bit"
570 -- | The VHDL Boolean type
571 bool_ty :: AST.TypeMark
572 bool_ty = AST.unsafeVHDLBasicId "Boolean"
574 -- | The VHDL std_logic
575 std_logic_ty :: AST.TypeMark
576 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
578 -- Translate a Haskell type to a VHDL type
579 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
581 typemap <- getA vsTypes
582 let builtin_ty = do -- See if this is a tycon and lookup its name
583 (tycon, args) <- Type.splitTyConApp_maybe ty
584 let name = Name.getOccString (TyCon.tyConName tycon)
585 Map.lookup name builtin_types
586 -- If not a builtin type, try the custom types
587 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
588 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
589 -- Found a type, return it
591 -- No type yet, try to construct it
593 newty_maybe <- (construct_vhdl_ty ty)
595 Just (ty_id, ty_def) -> do
596 -- TODO: Check name uniqueness
597 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_def))
599 Nothing -> error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty)
601 -- Construct a new VHDL type for the given Haskell type.
602 construct_vhdl_ty :: Type.Type -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
603 construct_vhdl_ty ty = do
604 case Type.splitTyConApp_maybe ty of
605 Just (tycon, args) -> do
606 let name = Name.getOccString (TyCon.tyConName tycon)
609 res <- mk_vector_ty (tfvec_len ty) (tfvec_elem ty)
610 return $ Just $ (Arrow.second Right) res
612 -- res <- mk_vector_ty (sized_word_len ty) ty
613 -- return $ Just $ (Arrow.second Left) res
615 res <- mk_natural_ty 0 (ranged_word_bound ty)
616 return $ Just $ (Arrow.second Right) res
617 -- Create a custom type from this tycon
618 otherwise -> mk_tycon_ty tycon args
619 Nothing -> return $ Nothing
621 -- | Create VHDL type for a custom tycon
622 mk_tycon_ty :: TyCon.TyCon -> [Type.Type] -> VHDLState (Maybe (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn))
623 mk_tycon_ty tycon args =
624 case TyCon.tyConDataCons tycon of
625 -- Not an algebraic type
626 [] -> error $ "Only custom algebraic types are supported: " ++ (showSDoc $ ppr tycon)
628 let arg_tys = DataCon.dataConRepArgTys dc
629 -- TODO: CoreSubst docs say each Subs can be applied only once. Is this a
630 -- violation? Or does it only mean not to apply it again to the same
632 let real_arg_tys = map (CoreSubst.substTy subst) arg_tys
633 elem_tys <- mapM vhdl_ty real_arg_tys
634 let elems = zipWith AST.ElementDec recordlabels elem_tys
635 -- For a single construct datatype, build a record with one field for
637 -- TODO: Add argument type ids to this, to ensure uniqueness
638 -- TODO: Special handling for tuples?
639 let ty_id = mkVHDLExtId $ nameToString (TyCon.tyConName tycon)
640 let ty_def = AST.TDR $ AST.RecordTypeDef elems
641 return $ Just (ty_id, Left ty_def)
642 dcs -> error $ "Only single constructor datatypes supported: " ++ (showSDoc $ ppr tycon)
644 -- Create a subst that instantiates all types passed to the tycon
645 -- TODO: I'm not 100% sure that this is the right way to do this. It seems
646 -- to work so far, though..
647 tyvars = TyCon.tyConTyVars tycon
648 subst = CoreSubst.extendTvSubstList CoreSubst.emptySubst (zip tyvars args)
650 -- | Create a VHDL vector type
652 Int -- ^ The length of the vector
653 -> Type.Type -- ^ The Haskell element type of the Vector
654 -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
656 mk_vector_ty len el_ty = do
657 elem_types_map <- getA vsElemTypes
658 el_ty_tm <- vhdl_ty el_ty
659 let ty_id = mkVHDLExtId $ "vector-"++ (AST.fromVHDLId el_ty_tm) ++ "-0_to_" ++ (show len)
660 let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
661 let existing_elem_ty = (fmap fst) $ Map.lookup (OrdType el_ty) elem_types_map
662 case existing_elem_ty of
664 let ty_def = AST.SubtypeIn t (Just range)
665 return (ty_id, ty_def)
667 let vec_id = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId el_ty_tm)
668 let vec_def = AST.TDA $ AST.UnconsArrayDef [tfvec_indexTM] el_ty_tm
669 modA vsElemTypes (Map.insert (OrdType el_ty) (vec_id, vec_def))
670 modA vsTypeFuns (Map.insert (OrdType el_ty) (genUnconsVectorFuns el_ty_tm vec_id))
671 let ty_def = AST.SubtypeIn vec_id (Just range)
672 return (ty_id, ty_def)
675 Int -- ^ The minimum bound (> 0)
676 -> Int -- ^ The maximum bound (> minimum bound)
677 -> VHDLState (AST.TypeMark, AST.SubtypeIn) -- The typemark created.
678 mk_natural_ty min_bound max_bound = do
679 let ty_id = mkVHDLExtId $ "nat_" ++ (show min_bound) ++ "_to_" ++ (show max_bound)
680 let range = AST.ConstraintRange $ AST.SubTypeRange (AST.PrimLit $ (show min_bound)) (AST.PrimLit $ (show max_bound))
681 let ty_def = AST.SubtypeIn naturalTM (Just range)
682 return (ty_id, ty_def)
686 ("Bit", std_logic_ty),
687 ("Bool", bool_ty) -- TysWiredIn.boolTy
691 -- Can only contain alphanumerics and underscores. The supplied string must be
692 -- a valid basic id, otherwise an error value is returned. This function is
693 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
695 mkVHDLBasicId :: String -> AST.VHDLId
697 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
699 -- Strip invalid characters.
700 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
701 -- Strip leading numbers and underscores
702 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
703 -- Strip multiple adjacent underscores
704 strip_multiscore = concat . map (\cs ->
710 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
711 -- different characters than basic ids, but can never be used to refer to
713 -- Use extended Ids for any values that are taken from the source file.
714 mkVHDLExtId :: String -> AST.VHDLId
716 AST.unsafeVHDLExtId $ strip_invalid s
718 -- Allowed characters, taken from ForSyde's mkVHDLExtId
719 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
720 strip_invalid = filter (`elem` allowed)
722 -- Creates a VHDL Id from a binder
727 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
729 -- Extracts the binder name as a String
733 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
735 -- Get the string version a Var's unique
736 varToStringUniq = show . Var.varUnique
738 -- Extracts the string version of the name
739 nameToString :: Name.Name -> String
740 nameToString = OccName.occNameString . Name.nameOccName
742 recordlabels = map (\c -> mkVHDLBasicId [c]) ['A'..'Z']
744 -- | Map a port specification of a builtin function to a VHDL Signal to put in
746 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
747 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)