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"]
56 mkUseAll ["work", "types"]
58 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
60 -- Create a use foo.bar.all statement. Takes a list of components in the used
61 -- name. Must contain at least two components
62 mkUseAll :: [String] -> AST.ContextItem
64 AST.Use $ from AST.:.: AST.All
66 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
67 from = foldl select base_prefix (tail ss)
68 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
72 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
74 createLibraryUnits flatfuncmap = do
75 let hsfuncs = Map.keys flatfuncmap
76 let flatfuncs = Map.elems flatfuncmap
77 entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
78 archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
81 let AST.EntityDec id _ = ent in
82 (id, [AST.LUEntity ent, AST.LUArch arch])
86 -- | Create an entity for a given function
88 HsFunction -- | The function signature
89 -> FlatFunction -- | The FlatFunction
90 -> VHDLState AST.EntityDec -- | The resulting entity
92 createEntity hsfunc flatfunc = do
93 let sigs = flat_sigs flatfunc
94 let args = flat_args flatfunc
95 let res = flat_res flatfunc
96 args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
97 res' <- Traversable.traverse (mkMap sigs) res
98 let ent_decl' = createEntityAST hsfunc args' res'
99 let AST.EntityDec entity_id _ = ent_decl'
100 let signature = Entity entity_id args' res'
101 modA vsSignatures (Map.insert hsfunc signature)
105 [(SignalId, SignalInfo)]
107 -> VHDLState VHDLSignalMapElement
108 -- We only need the vsTypes element from the state
109 mkMap sigmap = MonadState.lift vsTypes . (\id ->
111 info = Maybe.fromMaybe
112 (error $ "Signal not found in the name map? This should not happen!")
115 (error $ "Signal not named? This should not happen!")
119 if isPortSigUse $ sigUse info
121 type_mark <- vhdl_ty ty
122 return $ Just (mkVHDLExtId nm, type_mark)
127 -- | Create the VHDL AST for an entity
129 HsFunction -- | The signature of the function we're working with
130 -> [VHDLSignalMap] -- | The entity's arguments
131 -> VHDLSignalMap -- | The entity's result
132 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
134 createEntityAST hsfunc args res =
135 AST.EntityDec vhdl_id ports
137 vhdl_id = mkEntityId hsfunc
138 ports = concatMap (mapToPorts AST.In) args
139 ++ mapToPorts AST.Out res
141 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
143 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
144 -- Add a clk port if we have state
145 clk_port = if hasState hsfunc
147 [AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty]
151 -- | Create a port declaration
153 AST.Mode -- | The mode for the port (In / Out)
154 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
155 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
157 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
158 mkIfaceSigDec _ Nothing = Nothing
160 -- | Generate a VHDL entity name for the given hsfunc
162 -- TODO: This doesn't work for functions with multiple signatures!
163 -- Use a Basic Id, since using extended id's for entities throws off
164 -- precision and causes problems when generating filenames.
165 mkVHDLBasicId $ hsFuncName hsfunc
167 -- | Create an architecture for a given function
168 createArchitecture ::
169 HsFunction -- ^ The function signature
170 -> FlatFunction -- ^ The FlatFunction
171 -> VHDLState AST.ArchBody -- ^ The architecture for this function
173 createArchitecture hsfunc flatfunc = do
174 signaturemap <- getA vsSignatures
175 let signature = Maybe.fromMaybe
176 (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
177 (Map.lookup hsfunc signaturemap)
178 let entity_id = ent_id signature
179 -- Create signal declarations for all internal and state signals
180 sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
181 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
182 -- Create concurrent statements for all signal definitions
183 let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
184 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
186 sigs = flat_sigs flatfunc
187 args = flat_args flatfunc
188 res = flat_res flatfunc
189 defs = flat_defs flatfunc
190 procs = map mkStateProcSm (makeStatePairs flatfunc)
191 procs' = map AST.CSPSm procs
192 -- mkSigDec only uses vsTypes from the state
193 mkSigDec' = MonadState.lift vsTypes . mkSigDec
195 -- | Looks up all pairs of old state, new state signals, together with
196 -- the state id they represent.
197 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
198 makeStatePairs flatfunc =
199 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
200 | old_info <- map snd (flat_sigs flatfunc)
201 , new_info <- map snd (flat_sigs flatfunc)
202 -- old_info must be an old state (and, because of the next equality,
203 -- new_info must be a new state).
204 , Maybe.isJust $ oldStateId $ sigUse old_info
205 -- And the state numbers must match
206 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
208 -- Replace the second tuple element with the corresponding SignalInfo
209 --args_states = map (Arrow.second $ signalInfo sigs) args
210 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
211 mkStateProcSm (num, old, new) =
212 AST.ProcSm label [clk] [statement]
214 label = mkVHDLExtId $ "state_" ++ (show num)
215 clk = mkVHDLExtId "clk"
216 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
217 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
218 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
219 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
220 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
222 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
224 let use = sigUse info in
225 if isInternalSigUse use || isStateSigUse use then do
226 type_mark <- vhdl_ty ty
227 return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
233 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
235 getSignalId :: SignalInfo -> AST.VHDLId
237 mkVHDLExtId $ Maybe.fromMaybe
238 (error $ "Unnamed signal? This should not happen!")
241 -- | Transforms a signal definition into a VHDL concurrent statement
243 SignatureMap -- ^ The interfaces of functions in the session
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 -> AST.ConcSm -- ^ The corresponding VHDL component instantiation.
250 mkConcSm signatures sigs (FApp hsfunc args res) num =
252 signature = Maybe.fromMaybe
253 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
254 (Map.lookup hsfunc signatures)
255 entity_id = ent_id signature
256 label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
257 -- Add a clk port if we have state
258 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
259 portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
261 AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
263 mkConcSm _ sigs (UncondDef src dst) _ =
265 src_expr = vhdl_expr src
266 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
267 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
268 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
272 vhdl_expr (Left id) = mkIdExpr sigs id
273 vhdl_expr (Right expr) =
276 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
280 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
282 mkConcSm _ sigs (CondDef cond true false dst) _ =
284 cond_expr = mkIdExpr sigs cond
285 true_expr = mkIdExpr sigs true
286 false_expr = mkIdExpr sigs false
287 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
288 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
289 whenelse = AST.WhenElse true_wform cond_expr
290 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
291 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
295 -- | Turn a SignalId into a VHDL Expr
296 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
298 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
299 AST.PrimName src_name
302 [(SignalId, SignalInfo)] -- | The signals in the current architecture
303 -> [SignalMap] -- | The signals that are applied to function
304 -> SignalMap -- | the signals in which to store the function result
305 -> Entity -- | The entity to map against.
306 -> [AST.AssocElem] -- | The resulting port maps
308 mkAssocElems sigmap args res entity =
309 -- Create the actual AssocElems
310 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
312 -- Turn the ports and signals from a map into a flat list. This works,
313 -- since the maps must have an identical form by definition. TODO: Check
315 arg_ports = concat (map Foldable.toList (ent_args entity))
316 res_ports = Foldable.toList (ent_res entity)
317 arg_sigs = (concat (map Foldable.toList args))
318 res_sigs = Foldable.toList res
319 -- Extract the id part from the (id, type) tuple
320 ports = (map (fmap fst) (arg_ports ++ res_ports))
321 -- Translate signal numbers into names
322 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
324 -- | Look up a signal in the signal name map
325 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
326 lookupSigName sigs sig = name
328 info = Maybe.fromMaybe
329 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
331 name = Maybe.fromMaybe
332 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
335 -- | Create an VHDL port -> signal association
336 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
337 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
338 mkAssocElem Nothing _ = Nothing
340 -- | The VHDL Bit type
341 bit_ty :: AST.TypeMark
342 bit_ty = AST.unsafeVHDLBasicId "Bit"
344 -- | The VHDL Boolean type
345 bool_ty :: AST.TypeMark
346 bool_ty = AST.unsafeVHDLBasicId "Boolean"
348 -- | The VHDL std_logic
349 std_logic_ty :: AST.TypeMark
350 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
352 -- Translate a Haskell type to a VHDL type
353 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
356 let builtin_ty = do -- See if this is a tycon and lookup its name
357 (tycon, args) <- Type.splitTyConApp_maybe ty
358 let name = Name.getOccString (TyCon.tyConName tycon)
359 Map.lookup name builtin_types
360 -- If not a builtin type, try the custom types
361 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
362 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
363 -- Found a type, return it
365 -- No type yet, try to construct it
368 -- Use the Maybe Monad for failing when one of these fails
369 (tycon, args) <- Type.splitTyConApp_maybe ty
370 let name = Name.getOccString (TyCon.tyConName tycon)
372 "FSVec" -> Just $ mk_fsvec_ty ty args
374 -- Return new_ty when a new type was successfully created
376 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
379 -- | Create a VHDL type belonging to a FSVec Haskell type
381 Type.Type -- ^ The Haskell type to create a VHDL type for
382 -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
383 -> TypeState AST.TypeMark -- The typemark created.
385 mk_fsvec_ty ty args = do
386 -- Assume there are two type arguments
387 let [len, el_ty] = args
388 let len_int = eval_type_level_int len
389 let ty_id = mkVHDLExtId $ "vector_" ++ (show len_int)
391 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len_int - 1))]
392 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
393 let ty_dec = AST.TypeDec ty_id ty_def
394 -- TODO: Check name uniqueness
395 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
401 ("Bit", std_logic_ty),
402 ("Bool", bool_ty) -- TysWiredIn.boolTy
406 -- Can only contain alphanumerics and underscores. The supplied string must be
407 -- a valid basic id, otherwise an error value is returned. This function is
408 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
410 mkVHDLBasicId :: String -> AST.VHDLId
412 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
414 -- Strip invalid characters.
415 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
416 -- Strip leading numbers and underscores
417 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
418 -- Strip multiple adjacent underscores
419 strip_multiscore = concat . map (\cs ->
425 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
426 -- different characters than basic ids, but can never be used to refer to
428 -- Use extended Ids for any values that are taken from the source file.
429 mkVHDLExtId :: String -> AST.VHDLId
431 AST.unsafeVHDLExtId $ strip_invalid s
433 -- Allowed characters, taken from ForSyde's mkVHDLExtId
434 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
435 strip_invalid = filter (`elem` allowed)
437 -- | A consise representation of a (set of) ports on a builtin function
438 type PortMap = HsValueMap (String, AST.TypeMark)
439 -- | A consise representation of a builtin function
440 data BuiltIn = BuiltIn String [PortMap] PortMap
442 -- | Translate a list of concise representation of builtin functions to a
444 mkBuiltins :: [BuiltIn] -> SignatureMap
445 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
446 (HsFunction name (map useAsPort args) (useAsPort res),
447 Entity (VHDL.mkVHDLExtId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
450 builtin_hsfuncs = Map.keys builtin_funcs
451 builtin_funcs = mkBuiltins
453 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
454 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
455 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
456 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
459 -- | Map a port specification of a builtin function to a VHDL Signal to put in
461 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
462 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLExtId name, ty))