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
30 import qualified TyCon
31 import qualified DataCon
32 import Outputable ( showSDoc, ppr )
38 import TranslatorTypes
44 import GlobalNameTable
47 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
48 -> [(AST.VHDLId, AST.DesignFile)]
50 createDesignFiles binds =
51 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
52 map (Arrow.second $ AST.DesignFile full_context) units
55 init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
56 (units, final_session) =
57 State.runState (createLibraryUnits binds) init_session
58 ty_decls = Map.elems (final_session ^. vsTypes)
60 AST.Library $ mkVHDLBasicId "IEEE",
61 mkUseAll ["IEEE", "std_logic_1164"],
62 mkUseAll ["IEEE", "numeric_std"]
65 mkUseAll ["work", "types"]
67 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
69 -- Create a use foo.bar.all statement. Takes a list of components in the used
70 -- name. Must contain at least two components
71 mkUseAll :: [String] -> AST.ContextItem
73 AST.Use $ from AST.:.: AST.All
75 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
76 from = foldl select base_prefix (tail ss)
77 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
80 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
81 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
83 createLibraryUnits binds = do
84 entities <- Monad.mapM createEntity binds
85 archs <- Monad.mapM createArchitecture binds
88 let AST.EntityDec id _ = ent in
89 (id, [AST.LUEntity ent, AST.LUArch arch])
93 -- | Create an entity for a given function
95 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
96 -> VHDLState AST.EntityDec -- | The resulting entity
98 createEntity (fname, expr) = do
99 -- Strip off lambda's, these will be arguments
100 let (args, letexpr) = CoreSyn.collectBinders expr
101 args' <- Monad.mapM mkMap args
102 -- There must be a let at top level
103 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
105 let ent_decl' = createEntityAST fname args' res'
106 let AST.EntityDec entity_id _ = ent_decl'
107 let signature = Entity entity_id args' res'
108 modA vsSignatures (Map.insert (bndrToString fname) signature)
112 --[(SignalId, SignalInfo)]
114 -> VHDLState VHDLSignalMapElement
115 -- We only need the vsTypes element from the state
118 --info = Maybe.fromMaybe
119 -- (error $ "Signal not found in the name map? This should not happen!")
120 -- (lookup id sigmap)
121 -- Assume the bndr has a valid VHDL id already
122 id = bndrToVHDLId bndr
123 ty = Var.varType bndr
125 if True -- isPortSigUse $ sigUse info
127 type_mark <- vhdl_ty ty
128 return $ Just (id, type_mark)
133 -- | Create the VHDL AST for an entity
135 CoreSyn.CoreBndr -- | The name of the function
136 -> [VHDLSignalMapElement] -- | The entity's arguments
137 -> VHDLSignalMapElement -- | The entity's result
138 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
140 createEntityAST name args res =
141 AST.EntityDec vhdl_id ports
143 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
144 vhdl_id = mkVHDLBasicId $ bndrToString name
145 ports = Maybe.catMaybes $
146 map (mkIfaceSigDec AST.In) args
147 ++ [mkIfaceSigDec AST.Out res]
149 -- Add a clk port if we have state
150 clk_port = if True -- hasState hsfunc
152 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
156 -- | Create a port declaration
158 AST.Mode -- | The mode for the port (In / Out)
159 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
160 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
162 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
163 mkIfaceSigDec _ Nothing = Nothing
165 -- | Generate a VHDL entity name for the given hsfunc
167 -- TODO: This doesn't work for functions with multiple signatures!
168 -- Use a Basic Id, since using extended id's for entities throws off
169 -- precision and causes problems when generating filenames.
170 mkVHDLBasicId $ hsFuncName hsfunc
172 -- | Create an architecture for a given function
173 createArchitecture ::
174 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
175 -> VHDLState AST.ArchBody -- ^ The architecture for this function
177 createArchitecture (fname, expr) = do
178 --signaturemap <- getA vsSignatures
179 --let signature = Maybe.fromMaybe
180 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
181 -- (Map.lookup hsfunc signaturemap)
182 let entity_id = mkVHDLBasicId $ bndrToString fname
183 -- Strip off lambda's, these will be arguments
184 let (args, letexpr) = CoreSyn.collectBinders expr
185 -- There must be a let at top level
186 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
188 -- Create signal declarations for all internal and state signals
189 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
190 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
192 statements <- Monad.mapM mkConcSm binds
193 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
195 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
196 procs' = map AST.CSPSm procs
197 -- mkSigDec only uses vsTypes from the state
200 -- | Looks up all pairs of old state, new state signals, together with
201 -- the state id they represent.
202 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
203 makeStatePairs flatfunc =
204 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
205 | old_info <- map snd (flat_sigs flatfunc)
206 , new_info <- map snd (flat_sigs flatfunc)
207 -- old_info must be an old state (and, because of the next equality,
208 -- new_info must be a new state).
209 , Maybe.isJust $ oldStateId $ sigUse old_info
210 -- And the state numbers must match
211 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
213 -- Replace the second tuple element with the corresponding SignalInfo
214 --args_states = map (Arrow.second $ signalInfo sigs) args
215 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
216 mkStateProcSm (num, old, new) =
217 AST.ProcSm label [clk] [statement]
219 label = mkVHDLExtId $ "state_" ++ (show num)
220 clk = mkVHDLExtId "clk"
221 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
222 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
223 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
224 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
225 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
227 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
229 if True then do --isInternalSigUse use || isStateSigUse use then do
230 type_mark <- vhdl_ty $ Var.varType bndr
231 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
235 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
237 getSignalId :: SignalInfo -> AST.VHDLId
239 mkVHDLExtId $ Maybe.fromMaybe
240 (error $ "Unnamed signal? This should not happen!")
243 -- | Transforms a core binding into a VHDL concurrent statement
245 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
246 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
248 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
249 signatures <- getA vsSignatures
250 funSignatures <- getA vsNameTable
251 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
252 case (Map.lookup (bndrToString f) funSignatures) of
255 sigs = map (bndrToString.varBndr) args
256 sigsNames = map (\signal -> (AST.PrimName (AST.NSimple (mkVHDLExtId signal)))) sigs
257 func = (snd funSignature) sigsNames
258 src_wform = AST.Wform [AST.WformElem func Nothing]
259 dst_name = AST.NSimple (mkVHDLExtId (bndrToString bndr))
260 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
262 return $ AST.CSSASm assign
265 signature = Maybe.fromMaybe
266 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
267 (Map.lookup (bndrToString f) signatures)
268 entity_id = ent_id signature
269 label = bndrToString bndr
270 -- Add a clk port if we have state
271 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
272 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
273 portmaps = mkAssocElems args bndr signature
275 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
277 -- GHC generates some funny "r = r" bindings in let statements before
278 -- simplification. This outputs some dummy ConcSM for these, so things will at
279 -- least compile for now.
280 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
282 -- A single alt case must be a selector
283 mkConcSm (bndr, (Case (Var scrut) b ty [alt])) = error "Single case alt not supported yet"
285 -- Multiple case alt are be conditional assignments and have only wild
286 -- binders in the alts and only variables in the case values and a variable
287 -- for a scrutinee. We check the constructor of the second alt, since the
288 -- first is the default case, if there is any.
289 mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) =
291 cond_expr = (varToVHDLExpr scrut) AST.:=: (conToVHDLExpr con)
292 true_expr = (varToVHDLExpr true)
293 false_expr = (varToVHDLExpr false)
294 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
295 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
296 whenelse = AST.WhenElse true_wform cond_expr
297 dst_name = AST.NSimple (bndrToVHDLId bndr)
298 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
300 return $ AST.CSSASm assign
301 mkConcSm (_, (Case (Var _) _ _ alts)) = error "VHDL.mkConcSm Not in normal form: Case statement with more than two alternatives"
302 mkConcSm (_, Case _ _ _ _) = error "VHDL.mkConcSm Not in normal form: Case statement has does not have a simple variable as scrutinee"
304 -- Turn a variable reference into a AST expression
305 varToVHDLExpr :: Var.Var -> AST.Expr
306 varToVHDLExpr var = AST.PrimName $ AST.NSimple $ bndrToVHDLId var
308 -- Turn a constructor into an AST expression. For dataconstructors, this is
309 -- only the constructor itself, not any arguments it has. Should not be called
310 -- with a DEFAULT constructor.
311 conToVHDLExpr :: CoreSyn.AltCon -> AST.Expr
312 conToVHDLExpr (DataAlt dc) = AST.PrimLit lit
314 tycon = DataCon.dataConTyCon dc
315 tyname = TyCon.tyConName tycon
316 dcname = DataCon.dataConName dc
317 lit = case Name.getOccString tyname of
318 -- TODO: Do something more robust than string matching
319 "Bit" -> case Name.getOccString dcname of "High" -> "'1'"; "Low" -> "'0'"
320 "Bool" -> case Name.getOccString dcname of "True" -> "true"; "False" -> "false"
321 conToVHDLExpr (LitAlt _) = error "VHDL.conToVHDLExpr Literals not support in case alternatives yet"
322 conToVHDLExpr DEFAULT = error "VHDL.conToVHDLExpr DEFAULT alternative should not occur here!"
327 mkConcSm sigs (UncondDef src dst) _ = do
328 src_expr <- vhdl_expr src
329 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
330 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
331 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
332 return $ AST.CSSASm assign
334 vhdl_expr (Left id) = return $ mkIdExpr sigs id
335 vhdl_expr (Right expr) =
338 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
339 (Literal lit Nothing) ->
340 return $ AST.PrimLit lit
341 (Literal lit (Just ty)) -> do
342 -- Create a cast expression, which is just a function call using the
343 -- type name as the function name.
344 let litexpr = AST.PrimLit lit
346 let ty_name = AST.NSimple ty_id
347 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
348 return $ AST.PrimFCall $ AST.FCall ty_name args
350 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
352 mkConcSm sigs (CondDef cond true false dst) _ =
354 cond_expr = mkIdExpr sigs cond
355 true_expr = mkIdExpr sigs true
356 false_expr = mkIdExpr sigs false
357 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
358 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
359 whenelse = AST.WhenElse true_wform cond_expr
360 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
361 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
363 return $ AST.CSSASm assign
365 -- | Turn a SignalId into a VHDL Expr
366 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
368 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
369 AST.PrimName src_name
372 [CoreSyn.CoreExpr] -- | The argument that are applied to function
373 -> CoreSyn.CoreBndr -- | The binder in which to store the result
374 -> Entity -- | The entity to map against.
375 -> [AST.AssocElem] -- | The resulting port maps
377 mkAssocElems args res entity =
378 -- Create the actual AssocElems
379 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
381 -- Turn the ports and signals from a map into a flat list. This works,
382 -- since the maps must have an identical form by definition. TODO: Check
384 arg_ports = ent_args entity
385 res_port = ent_res entity
386 -- Extract the id part from the (id, type) tuple
387 ports = map (Monad.liftM fst) (res_port : arg_ports)
388 -- Translate signal numbers into names
389 sigs = (bndrToString res : map (bndrToString.varBndr) args)
391 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
392 -- simple Var CoreExprs, not complexer ones.
393 varBndr :: CoreSyn.CoreExpr -> Var.Id
394 varBndr (CoreSyn.Var id) = id
396 -- | Look up a signal in the signal name map
397 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
398 lookupSigName sigs sig = name
400 info = Maybe.fromMaybe
401 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
403 name = Maybe.fromMaybe
404 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
407 -- | Create an VHDL port -> signal association
408 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
409 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
410 mkAssocElem Nothing _ = Nothing
412 -- | The VHDL Bit type
413 bit_ty :: AST.TypeMark
414 bit_ty = AST.unsafeVHDLBasicId "Bit"
416 -- | The VHDL Boolean type
417 bool_ty :: AST.TypeMark
418 bool_ty = AST.unsafeVHDLBasicId "Boolean"
420 -- | The VHDL std_logic
421 std_logic_ty :: AST.TypeMark
422 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
424 -- Translate a Haskell type to a VHDL type
425 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
427 typemap <- getA vsTypes
428 let builtin_ty = do -- See if this is a tycon and lookup its name
429 (tycon, args) <- Type.splitTyConApp_maybe ty
430 let name = Name.getOccString (TyCon.tyConName tycon)
431 Map.lookup name builtin_types
432 -- If not a builtin type, try the custom types
433 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
434 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
435 -- Found a type, return it
437 -- No type yet, try to construct it
440 -- Use the Maybe Monad for failing when one of these fails
441 (tycon, args) <- Type.splitTyConApp_maybe ty
442 let name = Name.getOccString (TyCon.tyConName tycon)
444 "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
445 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
447 -- Return new_ty when a new type was successfully created
449 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
452 -- | Create a VHDL vector type
454 Int -- ^ The length of the vector
455 -> Type.Type -- ^ The Haskell type to create a VHDL type for
456 -> VHDLState AST.TypeMark -- The typemark created.
458 mk_vector_ty len ty = do
459 -- Assume there is a single type argument
460 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
462 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
463 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
464 let ty_dec = AST.TypeDec ty_id ty_def
465 -- TODO: Check name uniqueness
466 --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
467 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
468 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
474 ("Bit", std_logic_ty),
475 ("Bool", bool_ty) -- TysWiredIn.boolTy
479 -- Can only contain alphanumerics and underscores. The supplied string must be
480 -- a valid basic id, otherwise an error value is returned. This function is
481 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
483 mkVHDLBasicId :: String -> AST.VHDLId
485 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
487 -- Strip invalid characters.
488 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
489 -- Strip leading numbers and underscores
490 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
491 -- Strip multiple adjacent underscores
492 strip_multiscore = concat . map (\cs ->
498 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
499 -- different characters than basic ids, but can never be used to refer to
501 -- Use extended Ids for any values that are taken from the source file.
502 mkVHDLExtId :: String -> AST.VHDLId
504 AST.unsafeVHDLExtId $ strip_invalid s
506 -- Allowed characters, taken from ForSyde's mkVHDLExtId
507 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
508 strip_invalid = filter (`elem` allowed)
510 -- Creates a VHDL Id from a binder
515 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
517 -- Extracts the binder name as a String
522 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
524 -- | A consise representation of a (set of) ports on a builtin function
525 --type PortMap = HsValueMap (String, AST.TypeMark)
526 -- | A consise representation of a builtin function
527 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
529 -- | Translate a list of concise representation of builtin functions to a
531 mkBuiltins :: [BuiltIn] -> SignatureMap
532 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
534 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
537 builtin_hsfuncs = Map.keys builtin_funcs
538 builtin_funcs = mkBuiltins
540 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
541 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
542 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
543 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
546 -- | Map a port specification of a builtin function to a VHDL Signal to put in
548 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
549 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)