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
39 import GlobalNameTable
43 -> [(AST.VHDLId, AST.DesignFile)]
45 createDesignFiles flatfuncmap =
46 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
47 map (Arrow.second $ AST.DesignFile full_context) units
50 init_session = VHDLSession Map.empty builtin_funcs
51 (units, final_session) =
52 State.runState (createLibraryUnits flatfuncmap) init_session
53 ty_decls = Map.elems (final_session ^. vsTypes)
55 AST.Library $ mkVHDLBasicId "IEEE",
56 mkUseAll ["IEEE", "std_logic_1164"],
57 mkUseAll ["IEEE", "numeric_std"]
60 mkUseAll ["work", "types"]
62 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
64 -- Create a use foo.bar.all statement. Takes a list of components in the used
65 -- name. Must contain at least two components
66 mkUseAll :: [String] -> AST.ContextItem
68 AST.Use $ from AST.:.: AST.All
70 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
71 from = foldl select base_prefix (tail ss)
72 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
76 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
78 createLibraryUnits flatfuncmap = do
79 let hsfuncs = Map.keys flatfuncmap
80 let flatfuncs = Map.elems flatfuncmap
81 entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
82 archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
85 let AST.EntityDec id _ = ent in
86 (id, [AST.LUEntity ent, AST.LUArch arch])
90 -- | Create an entity for a given function
92 HsFunction -- | The function signature
93 -> FlatFunction -- | The FlatFunction
94 -> VHDLState AST.EntityDec -- | The resulting entity
96 createEntity hsfunc flatfunc = do
97 let sigs = flat_sigs flatfunc
98 let args = flat_args flatfunc
99 let res = flat_res flatfunc
100 args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
101 res' <- Traversable.traverse (mkMap sigs) res
102 let ent_decl' = createEntityAST hsfunc args' res'
103 let AST.EntityDec entity_id _ = ent_decl'
104 let signature = Entity entity_id args' res'
105 modA vsSignatures (Map.insert hsfunc signature)
109 [(SignalId, SignalInfo)]
111 -> VHDLState VHDLSignalMapElement
112 -- We only need the vsTypes element from the state
113 mkMap sigmap = MonadState.lift vsTypes . (\id ->
115 info = Maybe.fromMaybe
116 (error $ "Signal not found in the name map? This should not happen!")
119 (error $ "Signal not named? This should not happen!")
123 if isPortSigUse $ sigUse info
125 type_mark <- vhdl_ty ty
126 return $ Just (mkVHDLExtId nm, type_mark)
131 -- | Create the VHDL AST for an entity
133 HsFunction -- | The signature of the function we're working with
134 -> [VHDLSignalMap] -- | The entity's arguments
135 -> VHDLSignalMap -- | The entity's result
136 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
138 createEntityAST hsfunc args res =
139 AST.EntityDec vhdl_id ports
141 vhdl_id = mkEntityId hsfunc
142 ports = concatMap (mapToPorts AST.In) args
143 ++ mapToPorts AST.Out res
145 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
147 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
148 -- Add a clk port if we have state
149 clk_port = if hasState hsfunc
151 [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
155 -- | Create a port declaration
157 AST.Mode -- | The mode for the port (In / Out)
158 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
159 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
161 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
162 mkIfaceSigDec _ Nothing = Nothing
164 -- | Generate a VHDL entity name for the given hsfunc
166 -- TODO: This doesn't work for functions with multiple signatures!
167 -- Use a Basic Id, since using extended id's for entities throws off
168 -- precision and causes problems when generating filenames.
169 mkVHDLBasicId $ hsFuncName hsfunc
171 -- | Create an architecture for a given function
172 createArchitecture ::
173 HsFunction -- ^ The function signature
174 -> FlatFunction -- ^ The FlatFunction
175 -> VHDLState AST.ArchBody -- ^ The architecture for this function
177 createArchitecture hsfunc flatfunc = 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 = ent_id signature
183 -- Create signal declarations for all internal and state signals
184 sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
185 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
186 -- Create concurrent statements for all signal definitions
187 statements <- Monad.zipWithM (mkConcSm sigs) defs [0..]
188 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
190 sigs = flat_sigs flatfunc
191 args = flat_args flatfunc
192 res = flat_res flatfunc
193 defs = flat_defs flatfunc
194 procs = map mkStateProcSm (makeStatePairs flatfunc)
195 procs' = map AST.CSPSm procs
196 -- mkSigDec only uses vsTypes from the state
197 mkSigDec' = MonadState.lift vsTypes . mkSigDec
199 -- | Looks up all pairs of old state, new state signals, together with
200 -- the state id they represent.
201 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
202 makeStatePairs flatfunc =
203 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
204 | old_info <- map snd (flat_sigs flatfunc)
205 , new_info <- map snd (flat_sigs flatfunc)
206 -- old_info must be an old state (and, because of the next equality,
207 -- new_info must be a new state).
208 , Maybe.isJust $ oldStateId $ sigUse old_info
209 -- And the state numbers must match
210 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
212 -- Replace the second tuple element with the corresponding SignalInfo
213 --args_states = map (Arrow.second $ signalInfo sigs) args
214 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
215 mkStateProcSm (num, old, new) =
216 AST.ProcSm label [clk] [statement]
218 label = mkVHDLExtId $ "state_" ++ (show num)
219 clk = mkVHDLExtId "clk"
220 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
221 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
222 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
223 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
224 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
226 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
228 let use = sigUse info in
229 if isInternalSigUse use || isStateSigUse use then do
230 type_mark <- vhdl_ty ty
231 return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
237 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
239 getSignalId :: SignalInfo -> AST.VHDLId
241 mkVHDLExtId $ Maybe.fromMaybe
242 (error $ "Unnamed signal? This should not happen!")
245 -- | Transforms a signal definition into a VHDL concurrent statement
247 [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
248 -> SigDef -- ^ The signal definition
249 -> Int -- ^ A number that will be unique for all
250 -- concurrent statements in the architecture.
251 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
253 mkConcSm sigs (FApp hsfunc args res) num = do
254 signatures <- getA vsSignatures
256 signature = Maybe.fromMaybe
257 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
258 (Map.lookup hsfunc signatures)
259 entity_id = ent_id signature
260 label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
261 -- Add a clk port if we have state
262 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
263 portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
265 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
267 mkConcSm sigs (UncondDef src dst) _ = do
268 src_expr <- vhdl_expr src
269 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
270 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
271 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
272 return $ AST.CSSASm assign
274 vhdl_expr (Left id) = return $ mkIdExpr sigs id
275 vhdl_expr (Right expr) =
278 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
279 (Literal lit Nothing) ->
280 return $ AST.PrimLit lit
281 (Literal lit (Just ty)) -> do
282 -- Create a cast expression, which is just a function call using the
283 -- type name as the function name.
284 let litexpr = AST.PrimLit lit
285 ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
286 let ty_name = AST.NSimple ty_id
287 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
288 return $ AST.PrimFCall $ AST.FCall ty_name args
290 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
292 mkConcSm sigs (CondDef cond true false dst) _ =
294 cond_expr = mkIdExpr sigs cond
295 true_expr = mkIdExpr sigs true
296 false_expr = mkIdExpr sigs false
297 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
298 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
299 whenelse = AST.WhenElse true_wform cond_expr
300 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
301 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
303 return $ AST.CSSASm assign
305 -- | Turn a SignalId into a VHDL Expr
306 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
308 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
309 AST.PrimName src_name
312 [(SignalId, SignalInfo)] -- | The signals in the current architecture
313 -> [SignalMap] -- | The signals that are applied to function
314 -> SignalMap -- | the signals in which to store the function result
315 -> Entity -- | The entity to map against.
316 -> [AST.AssocElem] -- | The resulting port maps
318 mkAssocElems sigmap args res entity =
319 -- Create the actual AssocElems
320 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
322 -- Turn the ports and signals from a map into a flat list. This works,
323 -- since the maps must have an identical form by definition. TODO: Check
325 arg_ports = concat (map Foldable.toList (ent_args entity))
326 res_ports = Foldable.toList (ent_res entity)
327 arg_sigs = (concat (map Foldable.toList args))
328 res_sigs = Foldable.toList res
329 -- Extract the id part from the (id, type) tuple
330 ports = (map (fmap fst) (arg_ports ++ res_ports))
331 -- Translate signal numbers into names
332 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
334 -- | Look up a signal in the signal name map
335 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
336 lookupSigName sigs sig = name
338 info = Maybe.fromMaybe
339 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
341 name = Maybe.fromMaybe
342 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
345 -- | Create an VHDL port -> signal association
346 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
347 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
348 mkAssocElem Nothing _ = Nothing
350 -- | The VHDL Bit type
351 bit_ty :: AST.TypeMark
352 bit_ty = AST.unsafeVHDLBasicId "Bit"
354 -- | The VHDL Boolean type
355 bool_ty :: AST.TypeMark
356 bool_ty = AST.unsafeVHDLBasicId "Boolean"
358 -- | The VHDL std_logic
359 std_logic_ty :: AST.TypeMark
360 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
362 -- Translate a Haskell type to a VHDL type
363 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
366 let builtin_ty = do -- See if this is a tycon and lookup its name
367 (tycon, args) <- Type.splitTyConApp_maybe ty
368 let name = Name.getOccString (TyCon.tyConName tycon)
369 Map.lookup name builtin_types
370 -- If not a builtin type, try the custom types
371 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
372 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
373 -- Found a type, return it
375 -- No type yet, try to construct it
378 -- Use the Maybe Monad for failing when one of these fails
379 (tycon, args) <- Type.splitTyConApp_maybe ty
380 let name = Name.getOccString (TyCon.tyConName tycon)
382 "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
383 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
385 -- Return new_ty when a new type was successfully created
387 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
390 -- | Create a VHDL vector type
392 Int -- ^ The length of the vector
393 -> Type.Type -- ^ The Haskell type to create a VHDL type for
394 -> TypeState AST.TypeMark -- The typemark created.
396 mk_vector_ty len ty = do
397 -- Assume there is a single type argument
398 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
400 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
401 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
402 let ty_dec = AST.TypeDec ty_id ty_def
403 -- TODO: Check name uniqueness
404 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
410 ("Bit", std_logic_ty),
411 ("Bool", bool_ty) -- TysWiredIn.boolTy
415 -- Can only contain alphanumerics and underscores. The supplied string must be
416 -- a valid basic id, otherwise an error value is returned. This function is
417 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
419 mkVHDLBasicId :: String -> AST.VHDLId
421 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
423 -- Strip invalid characters.
424 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
425 -- Strip leading numbers and underscores
426 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
427 -- Strip multiple adjacent underscores
428 strip_multiscore = concat . map (\cs ->
434 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
435 -- different characters than basic ids, but can never be used to refer to
437 -- Use extended Ids for any values that are taken from the source file.
438 mkVHDLExtId :: String -> AST.VHDLId
440 AST.unsafeVHDLExtId $ strip_invalid s
442 -- Allowed characters, taken from ForSyde's mkVHDLExtId
443 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
444 strip_invalid = filter (`elem` allowed)
446 -- | A consise representation of a (set of) ports on a builtin function
447 type PortMap = HsValueMap (String, AST.TypeMark)
448 -- | A consise representation of a builtin function
449 data BuiltIn = BuiltIn String [PortMap] PortMap
451 -- | Translate a list of concise representation of builtin functions to a
453 mkBuiltins :: [BuiltIn] -> SignatureMap
454 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
455 (HsFunction name (map useAsPort args) (useAsPort res),
456 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
459 builtin_hsfuncs = Map.keys builtin_funcs
460 builtin_funcs = mkBuiltins
462 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
463 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
464 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
465 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
468 -- | Map a port specification of a builtin function to a VHDL Signal to put in
470 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
471 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))