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
21 import qualified ForSyDe.Backend.VHDL.AST as AST
26 import qualified TyCon
27 import Outputable ( showSDoc, ppr )
33 import TranslatorTypes
40 -> [(AST.VHDLId, AST.DesignFile)]
42 createDesignFiles flatfuncmap =
43 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
44 map (Arrow.second $ AST.DesignFile full_context) units
47 init_session = VHDLSession Map.empty builtin_funcs
48 (units, final_session) =
49 State.runState (createLibraryUnits flatfuncmap) init_session
50 ty_decls = Map.elems (final_session ^. vsTypes)
52 AST.Library $ mkVHDLBasicId "IEEE",
53 mkUseAll ["IEEE", "std_logic_1164"],
54 mkUseAll ["IEEE", "numeric_std"]
57 mkUseAll ["work", "types"]
59 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
61 -- Create a use foo.bar.all statement. Takes a list of components in the used
62 -- name. Must contain at least two components
63 mkUseAll :: [String] -> AST.ContextItem
65 AST.Use $ from AST.:.: AST.All
67 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
68 from = foldl select base_prefix (tail ss)
69 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
73 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
75 createLibraryUnits flatfuncmap = do
76 let hsfuncs = Map.keys flatfuncmap
77 let flatfuncs = Map.elems flatfuncmap
78 entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
79 archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
82 let AST.EntityDec id _ = ent in
83 (id, [AST.LUEntity ent, AST.LUArch arch])
87 -- | Create an entity for a given function
89 HsFunction -- | The function signature
90 -> FlatFunction -- | The FlatFunction
91 -> VHDLState AST.EntityDec -- | The resulting entity
93 createEntity hsfunc flatfunc = do
94 let sigs = flat_sigs flatfunc
95 let args = flat_args flatfunc
96 let res = flat_res flatfunc
97 args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
98 res' <- Traversable.traverse (mkMap sigs) res
99 let ent_decl' = createEntityAST hsfunc args' res'
100 let AST.EntityDec entity_id _ = ent_decl'
101 let signature = Entity entity_id args' res'
102 modA vsSignatures (Map.insert hsfunc signature)
106 [(SignalId, SignalInfo)]
108 -> VHDLState VHDLSignalMapElement
109 -- We only need the vsTypes element from the state
110 mkMap sigmap = MonadState.lift vsTypes . (\id ->
112 info = Maybe.fromMaybe
113 (error $ "Signal not found in the name map? This should not happen!")
116 (error $ "Signal not named? This should not happen!")
120 if isPortSigUse $ sigUse info
122 type_mark <- vhdl_ty ty
123 return $ Just (mkVHDLExtId nm, type_mark)
128 -- | Create the VHDL AST for an entity
130 HsFunction -- | The signature of the function we're working with
131 -> [VHDLSignalMap] -- | The entity's arguments
132 -> VHDLSignalMap -- | The entity's result
133 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
135 createEntityAST hsfunc args res =
136 AST.EntityDec vhdl_id ports
138 vhdl_id = mkEntityId hsfunc
139 ports = concatMap (mapToPorts AST.In) args
140 ++ mapToPorts AST.Out res
142 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
144 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
145 -- Add a clk port if we have state
146 clk_port = if hasState hsfunc
148 [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
152 -- | Create a port declaration
154 AST.Mode -- | The mode for the port (In / Out)
155 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
156 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
158 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
159 mkIfaceSigDec _ Nothing = Nothing
161 -- | Generate a VHDL entity name for the given hsfunc
163 -- TODO: This doesn't work for functions with multiple signatures!
164 -- Use a Basic Id, since using extended id's for entities throws off
165 -- precision and causes problems when generating filenames.
166 mkVHDLBasicId $ hsFuncName hsfunc
168 -- | Create an architecture for a given function
169 createArchitecture ::
170 HsFunction -- ^ The function signature
171 -> FlatFunction -- ^ The FlatFunction
172 -> VHDLState AST.ArchBody -- ^ The architecture for this function
174 createArchitecture hsfunc flatfunc = do
175 signaturemap <- getA vsSignatures
176 let signature = Maybe.fromMaybe
177 (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
178 (Map.lookup hsfunc signaturemap)
179 let entity_id = ent_id signature
180 -- Create signal declarations for all internal and state signals
181 sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
182 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
183 -- Create concurrent statements for all signal definitions
184 statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
185 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
187 sigs = flat_sigs flatfunc
188 args = flat_args flatfunc
189 res = flat_res flatfunc
190 defs = flat_defs flatfunc
191 procs = map mkStateProcSm (makeStatePairs flatfunc)
192 procs' = map AST.CSPSm procs
193 -- mkSigDec only uses vsTypes from the state
194 mkSigDec' = MonadState.lift vsTypes . mkSigDec
196 -- | Looks up all pairs of old state, new state signals, together with
197 -- the state id they represent.
198 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
199 makeStatePairs flatfunc =
200 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
201 | old_info <- map snd (flat_sigs flatfunc)
202 , new_info <- map snd (flat_sigs flatfunc)
203 -- old_info must be an old state (and, because of the next equality,
204 -- new_info must be a new state).
205 , Maybe.isJust $ oldStateId $ sigUse old_info
206 -- And the state numbers must match
207 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
209 -- Replace the second tuple element with the corresponding SignalInfo
210 --args_states = map (Arrow.second $ signalInfo sigs) args
211 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
212 mkStateProcSm (num, old, new) =
213 AST.ProcSm label [clk] [statement]
215 label = mkVHDLExtId $ "state_" ++ (show num)
216 clk = mkVHDLExtId "clk"
217 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
218 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
219 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
220 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
221 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
223 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
225 let use = sigUse info in
226 if isInternalSigUse use || isStateSigUse use then do
227 type_mark <- vhdl_ty ty
228 return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
234 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
236 getSignalId :: SignalInfo -> AST.VHDLId
238 mkVHDLExtId $ Maybe.fromMaybe
239 (error $ "Unnamed signal? This should not happen!")
242 -- | Transforms a signal definition into a VHDL concurrent statement
244 [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
245 -> SigDef -- ^ The signal definition
246 -> Int -- ^ A number that will be unique for all
247 -- concurrent statements in the architecture.
248 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
250 mkConcSm sigs (FApp hsfunc args res) num = do
251 signatures <- getA vsSignatures
253 signature = Maybe.fromMaybe
254 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
255 (Map.lookup hsfunc signatures)
256 entity_id = ent_id signature
257 label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
258 -- Add a clk port if we have state
259 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
260 portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
262 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
264 mkConcSm sigs (UncondDef src dst) _ = do
265 src_expr <- vhdl_expr src
266 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
267 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
268 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
269 return $ AST.CSSASm assign
271 vhdl_expr (Left id) = return $ mkIdExpr sigs id
272 vhdl_expr (Right expr) =
275 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
276 (Literal lit Nothing) ->
277 return $ AST.PrimLit lit
278 (Literal lit (Just ty)) -> do
279 -- Create a cast expression, which is just a function call using the
280 -- type name as the function name.
281 let litexpr = AST.PrimLit lit
282 ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
283 let ty_name = AST.NSimple ty_id
284 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
285 return $ AST.PrimFCall $ AST.FCall ty_name args
287 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
289 mkConcSm sigs (CondDef cond true false dst) _ =
291 cond_expr = mkIdExpr sigs cond
292 true_expr = mkIdExpr sigs true
293 false_expr = mkIdExpr sigs 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 (getSignalId $ signalInfo sigs dst)
298 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
300 return $ AST.CSSASm assign
302 -- | Turn a SignalId into a VHDL Expr
303 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
305 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
306 AST.PrimName src_name
309 [(SignalId, SignalInfo)] -- | The signals in the current architecture
310 -> [SignalMap] -- | The signals that are applied to function
311 -> SignalMap -- | the signals in which to store the function result
312 -> Entity -- | The entity to map against.
313 -> [AST.AssocElem] -- | The resulting port maps
315 mkAssocElems sigmap args res entity =
316 -- Create the actual AssocElems
317 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
319 -- Turn the ports and signals from a map into a flat list. This works,
320 -- since the maps must have an identical form by definition. TODO: Check
322 arg_ports = concat (map Foldable.toList (ent_args entity))
323 res_ports = Foldable.toList (ent_res entity)
324 arg_sigs = (concat (map Foldable.toList args))
325 res_sigs = Foldable.toList res
326 -- Extract the id part from the (id, type) tuple
327 ports = (map (fmap fst) (arg_ports ++ res_ports))
328 -- Translate signal numbers into names
329 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
331 -- | Look up a signal in the signal name map
332 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
333 lookupSigName sigs sig = name
335 info = Maybe.fromMaybe
336 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
338 name = Maybe.fromMaybe
339 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
342 -- | Create an VHDL port -> signal association
343 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
344 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
345 mkAssocElem Nothing _ = Nothing
347 -- | The VHDL Bit type
348 bit_ty :: AST.TypeMark
349 bit_ty = AST.unsafeVHDLBasicId "Bit"
351 -- | The VHDL Boolean type
352 bool_ty :: AST.TypeMark
353 bool_ty = AST.unsafeVHDLBasicId "Boolean"
355 -- | The VHDL std_logic
356 std_logic_ty :: AST.TypeMark
357 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
359 -- Translate a Haskell type to a VHDL type
360 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
363 let builtin_ty = do -- See if this is a tycon and lookup its name
364 (tycon, args) <- Type.splitTyConApp_maybe ty
365 let name = Name.getOccString (TyCon.tyConName tycon)
366 Map.lookup name builtin_types
367 -- If not a builtin type, try the custom types
368 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
369 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
370 -- Found a type, return it
372 -- No type yet, try to construct it
375 -- Use the Maybe Monad for failing when one of these fails
376 (tycon, args) <- Type.splitTyConApp_maybe ty
377 let name = Name.getOccString (TyCon.tyConName tycon)
379 "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
380 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
382 -- Return new_ty when a new type was successfully created
384 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
387 -- | Create a VHDL vector type
389 Int -- ^ The length of the vector
390 -> Type.Type -- ^ The Haskell type to create a VHDL type for
391 -> TypeState AST.TypeMark -- The typemark created.
393 mk_vector_ty len ty = do
394 -- Assume there is a single type argument
395 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
397 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
398 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
399 let ty_dec = AST.TypeDec ty_id ty_def
400 -- TODO: Check name uniqueness
401 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
407 ("Bit", std_logic_ty),
408 ("Bool", bool_ty) -- TysWiredIn.boolTy
412 -- Can only contain alphanumerics and underscores. The supplied string must be
413 -- a valid basic id, otherwise an error value is returned. This function is
414 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
416 mkVHDLBasicId :: String -> AST.VHDLId
418 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
420 -- Strip invalid characters.
421 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
422 -- Strip leading numbers and underscores
423 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
424 -- Strip multiple adjacent underscores
425 strip_multiscore = concat . map (\cs ->
431 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
432 -- different characters than basic ids, but can never be used to refer to
434 -- Use extended Ids for any values that are taken from the source file.
435 mkVHDLExtId :: String -> AST.VHDLId
437 AST.unsafeVHDLExtId $ strip_invalid s
439 -- Allowed characters, taken from ForSyde's mkVHDLExtId
440 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
441 strip_invalid = filter (`elem` allowed)
443 -- | A consise representation of a (set of) ports on a builtin function
444 type PortMap = HsValueMap (String, AST.TypeMark)
445 -- | A consise representation of a builtin function
446 data BuiltIn = BuiltIn String [PortMap] PortMap
448 -- | Translate a list of concise representation of builtin functions to a
450 mkBuiltins :: [BuiltIn] -> SignatureMap
451 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
452 (HsFunction name (map useAsPort args) (useAsPort res),
453 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
456 builtin_hsfuncs = Map.keys builtin_funcs
457 builtin_funcs = mkBuiltins
459 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
460 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
461 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
462 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
465 -- | Map a port specification of a builtin function to a VHDL Signal to put in
467 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
468 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))