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 let statements = zipWith (mkConcSm signaturemap 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 SignatureMap -- ^ The interfaces of functions in the session
245 -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
246 -> SigDef -- ^ The signal definition
247 -> Int -- ^ A number that will be unique for all
248 -- concurrent statements in the architecture.
249 -> AST.ConcSm -- ^ The corresponding VHDL component instantiation.
251 mkConcSm signatures sigs (FApp hsfunc args res) num =
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 AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
264 mkConcSm _ sigs (UncondDef src dst) _ =
266 src_expr = vhdl_expr src
267 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
268 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
269 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
273 vhdl_expr (Left id) = mkIdExpr sigs id
274 vhdl_expr (Right expr) =
277 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
281 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
283 mkConcSm _ sigs (CondDef cond true false dst) _ =
285 cond_expr = mkIdExpr sigs cond
286 true_expr = mkIdExpr sigs true
287 false_expr = mkIdExpr sigs false
288 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
289 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
290 whenelse = AST.WhenElse true_wform cond_expr
291 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
292 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
296 -- | Turn a SignalId into a VHDL Expr
297 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
299 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
300 AST.PrimName src_name
303 [(SignalId, SignalInfo)] -- | The signals in the current architecture
304 -> [SignalMap] -- | The signals that are applied to function
305 -> SignalMap -- | the signals in which to store the function result
306 -> Entity -- | The entity to map against.
307 -> [AST.AssocElem] -- | The resulting port maps
309 mkAssocElems sigmap args res entity =
310 -- Create the actual AssocElems
311 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
313 -- Turn the ports and signals from a map into a flat list. This works,
314 -- since the maps must have an identical form by definition. TODO: Check
316 arg_ports = concat (map Foldable.toList (ent_args entity))
317 res_ports = Foldable.toList (ent_res entity)
318 arg_sigs = (concat (map Foldable.toList args))
319 res_sigs = Foldable.toList res
320 -- Extract the id part from the (id, type) tuple
321 ports = (map (fmap fst) (arg_ports ++ res_ports))
322 -- Translate signal numbers into names
323 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
325 -- | Look up a signal in the signal name map
326 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
327 lookupSigName sigs sig = name
329 info = Maybe.fromMaybe
330 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
332 name = Maybe.fromMaybe
333 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
336 -- | Create an VHDL port -> signal association
337 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
338 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
339 mkAssocElem Nothing _ = Nothing
341 -- | The VHDL Bit type
342 bit_ty :: AST.TypeMark
343 bit_ty = AST.unsafeVHDLBasicId "Bit"
345 -- | The VHDL Boolean type
346 bool_ty :: AST.TypeMark
347 bool_ty = AST.unsafeVHDLBasicId "Boolean"
349 -- | The VHDL std_logic
350 std_logic_ty :: AST.TypeMark
351 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
353 -- Translate a Haskell type to a VHDL type
354 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
357 let builtin_ty = do -- See if this is a tycon and lookup its name
358 (tycon, args) <- Type.splitTyConApp_maybe ty
359 let name = Name.getOccString (TyCon.tyConName tycon)
360 Map.lookup name builtin_types
361 -- If not a builtin type, try the custom types
362 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
363 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
364 -- Found a type, return it
366 -- No type yet, try to construct it
369 -- Use the Maybe Monad for failing when one of these fails
370 (tycon, args) <- Type.splitTyConApp_maybe ty
371 let name = Name.getOccString (TyCon.tyConName tycon)
373 "FSVec" -> Just $ mk_fsvec_ty ty args
374 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
376 -- Return new_ty when a new type was successfully created
378 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
381 -- | Create a VHDL type belonging to a FSVec Haskell type
383 Type.Type -- ^ The Haskell type to create a VHDL type for
384 -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
385 -> TypeState AST.TypeMark -- The typemark created.
387 mk_fsvec_ty ty args = do
388 -- Assume there are two type arguments
389 let [len, el_ty] = args
390 let len_int = eval_type_level_int len
391 let ty_id = mkVHDLExtId $ "vector_" ++ (show len_int)
393 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len_int - 1))]
394 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
395 let ty_dec = AST.TypeDec ty_id ty_def
396 -- TODO: Check name uniqueness
397 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
400 -- | Create a VHDL vector type
402 Int -- ^ The length of the vector
403 -> Type.Type -- ^ The Haskell type to create a VHDL type for
404 -> TypeState AST.TypeMark -- The typemark created.
406 mk_vector_ty len ty = do
407 -- Assume there is a single type argument
408 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
410 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
411 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
412 let ty_dec = AST.TypeDec ty_id ty_def
413 -- TODO: Check name uniqueness
414 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
420 ("Bit", std_logic_ty),
421 ("Bool", bool_ty) -- TysWiredIn.boolTy
425 -- Can only contain alphanumerics and underscores. The supplied string must be
426 -- a valid basic id, otherwise an error value is returned. This function is
427 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
429 mkVHDLBasicId :: String -> AST.VHDLId
431 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
433 -- Strip invalid characters.
434 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
435 -- Strip leading numbers and underscores
436 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
437 -- Strip multiple adjacent underscores
438 strip_multiscore = concat . map (\cs ->
444 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
445 -- different characters than basic ids, but can never be used to refer to
447 -- Use extended Ids for any values that are taken from the source file.
448 mkVHDLExtId :: String -> AST.VHDLId
450 AST.unsafeVHDLExtId $ strip_invalid s
452 -- Allowed characters, taken from ForSyde's mkVHDLExtId
453 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
454 strip_invalid = filter (`elem` allowed)
456 -- | A consise representation of a (set of) ports on a builtin function
457 type PortMap = HsValueMap (String, AST.TypeMark)
458 -- | A consise representation of a builtin function
459 data BuiltIn = BuiltIn String [PortMap] PortMap
461 -- | Translate a list of concise representation of builtin functions to a
463 mkBuiltins :: [BuiltIn] -> SignatureMap
464 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
465 (HsFunction name (map useAsPort args) (useAsPort res),
466 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
469 builtin_hsfuncs = Map.keys builtin_funcs
470 builtin_funcs = mkBuiltins
472 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
473 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
474 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
475 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
478 -- | Map a port specification of a builtin function to a VHDL Signal to put in
480 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
481 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLBasicId name, ty))