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
20 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import qualified TyCon
26 import Outputable ( showSDoc, ppr )
32 import TranslatorTypes
39 -> [(AST.VHDLId, AST.DesignFile)]
41 createDesignFiles flatfuncmap =
42 (mkVHDLId "types", AST.DesignFile ieee_context [type_package]) :
43 map (Arrow.second $ AST.DesignFile full_context) units
46 init_session = VHDLSession Map.empty builtin_funcs
47 (units, final_session) =
48 State.runState (createLibraryUnits flatfuncmap) init_session
49 ty_decls = Map.elems (final_session ^. vsTypes)
51 AST.Library $ mkVHDLId "IEEE",
52 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All
55 (AST.Use $ (AST.NSimple $ mkVHDLId "work.types") AST.:.: AST.All)
57 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLId "types") (map (AST.PDITD . snd) ty_decls)
61 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
63 createLibraryUnits flatfuncmap = do
64 let hsfuncs = Map.keys flatfuncmap
65 let flatfuncs = Map.elems flatfuncmap
66 entities <- Monad.zipWithM createEntity hsfuncs flatfuncs
67 archs <- Monad.zipWithM createArchitecture hsfuncs flatfuncs
70 let AST.EntityDec id _ = ent in
71 (id, [AST.LUEntity ent, AST.LUArch arch])
75 -- | Create an entity for a given function
77 HsFunction -- | The function signature
78 -> FlatFunction -- | The FlatFunction
79 -> VHDLState AST.EntityDec -- | The resulting entity
81 createEntity hsfunc flatfunc = do
82 let sigs = flat_sigs flatfunc
83 let args = flat_args flatfunc
84 let res = flat_res flatfunc
85 args' <- Traversable.traverse (Traversable.traverse (mkMap sigs)) args
86 res' <- Traversable.traverse (mkMap sigs) res
87 let ent_decl' = createEntityAST hsfunc args' res'
88 let AST.EntityDec entity_id _ = ent_decl'
89 let signature = Entity entity_id args' res'
90 modA vsSignatures (Map.insert hsfunc signature)
94 [(SignalId, SignalInfo)]
96 -> VHDLState VHDLSignalMapElement
97 -- We only need the vsTypes element from the state
98 mkMap sigmap = MonadState.lift vsTypes . (\id ->
100 info = Maybe.fromMaybe
101 (error $ "Signal not found in the name map? This should not happen!")
104 (error $ "Signal not named? This should not happen!")
108 if isPortSigUse $ sigUse info
110 type_mark <- vhdl_ty ty
111 return $ Just (mkVHDLId nm, type_mark)
116 -- | Create the VHDL AST for an entity
118 HsFunction -- | The signature of the function we're working with
119 -> [VHDLSignalMap] -- | The entity's arguments
120 -> VHDLSignalMap -- | The entity's result
121 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
123 createEntityAST hsfunc args res =
124 AST.EntityDec vhdl_id ports
126 vhdl_id = mkEntityId hsfunc
127 ports = concatMap (mapToPorts AST.In) args
128 ++ mapToPorts AST.Out res
130 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
132 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
133 -- Add a clk port if we have state
134 clk_port = if hasState hsfunc
136 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
140 -- | Create a port declaration
142 AST.Mode -- | The mode for the port (In / Out)
143 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
144 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
146 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
147 mkIfaceSigDec _ Nothing = Nothing
149 -- | Generate a VHDL entity name for the given hsfunc
151 -- TODO: This doesn't work for functions with multiple signatures!
152 mkVHDLId $ hsFuncName hsfunc
154 -- | Create an architecture for a given function
155 createArchitecture ::
156 HsFunction -- ^ The function signature
157 -> FlatFunction -- ^ The FlatFunction
158 -> VHDLState AST.ArchBody -- ^ The architecture for this function
160 createArchitecture hsfunc flatfunc = do
161 signaturemap <- getA vsSignatures
162 let signature = Maybe.fromMaybe
163 (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
164 (Map.lookup hsfunc signaturemap)
165 let entity_id = ent_id signature
166 -- Create signal declarations for all internal and state signals
167 sig_dec_maybes <- mapM (mkSigDec' . snd) sigs
168 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
169 -- Create concurrent statements for all signal definitions
170 let statements = zipWith (mkConcSm signaturemap sigs) defs [0..]
171 return $ AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
173 sigs = flat_sigs flatfunc
174 args = flat_args flatfunc
175 res = flat_res flatfunc
176 defs = flat_defs flatfunc
177 procs = map mkStateProcSm (makeStatePairs flatfunc)
178 procs' = map AST.CSPSm procs
179 -- mkSigDec only uses vsTypes from the state
180 mkSigDec' = MonadState.lift vsTypes . mkSigDec
182 -- | Looks up all pairs of old state, new state signals, together with
183 -- the state id they represent.
184 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
185 makeStatePairs flatfunc =
186 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
187 | old_info <- map snd (flat_sigs flatfunc)
188 , new_info <- map snd (flat_sigs flatfunc)
189 -- old_info must be an old state (and, because of the next equality,
190 -- new_info must be a new state).
191 , Maybe.isJust $ oldStateId $ sigUse old_info
192 -- And the state numbers must match
193 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
195 -- Replace the second tuple element with the corresponding SignalInfo
196 --args_states = map (Arrow.second $ signalInfo sigs) args
197 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
198 mkStateProcSm (num, old, new) =
199 AST.ProcSm label [clk] [statement]
201 label = mkVHDLId $ "state_" ++ (show num)
203 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
204 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
205 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
206 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
207 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
209 mkSigDec :: SignalInfo -> TypeState (Maybe AST.SigDec)
211 let use = sigUse info in
212 if isInternalSigUse use || isStateSigUse use then do
213 type_mark <- vhdl_ty ty
214 return $ Just (AST.SigDec (getSignalId info) type_mark Nothing)
220 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
222 getSignalId :: SignalInfo -> AST.VHDLId
224 mkVHDLId $ Maybe.fromMaybe
225 (error $ "Unnamed signal? This should not happen!")
228 -- | Transforms a signal definition into a VHDL concurrent statement
230 SignatureMap -- ^ The interfaces of functions in the session
231 -> [(SignalId, SignalInfo)] -- ^ The signals in the current architecture
232 -> SigDef -- ^ The signal definition
233 -> Int -- ^ A number that will be unique for all
234 -- concurrent statements in the architecture.
235 -> AST.ConcSm -- ^ The corresponding VHDL component instantiation.
237 mkConcSm signatures sigs (FApp hsfunc args res) num =
239 signature = Maybe.fromMaybe
240 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without signature? This should not happen!")
241 (Map.lookup hsfunc signatures)
242 entity_id = ent_id signature
243 label = (AST.fromVHDLId entity_id) ++ "_" ++ (show num)
244 -- Add a clk port if we have state
245 clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
246 portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
248 AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
250 mkConcSm _ sigs (UncondDef src dst) _ =
252 src_expr = vhdl_expr src
253 src_wform = AST.Wform [AST.WformElem src_expr Nothing]
254 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
255 assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
259 vhdl_expr (Left id) = mkIdExpr sigs id
260 vhdl_expr (Right expr) =
263 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
267 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
269 mkConcSm _ sigs (CondDef cond true false dst) _ =
271 cond_expr = mkIdExpr sigs cond
272 true_expr = mkIdExpr sigs true
273 false_expr = mkIdExpr sigs false
274 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
275 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
276 whenelse = AST.WhenElse true_wform cond_expr
277 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
278 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
282 -- | Turn a SignalId into a VHDL Expr
283 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
285 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
286 AST.PrimName src_name
289 [(SignalId, SignalInfo)] -- | The signals in the current architecture
290 -> [SignalMap] -- | The signals that are applied to function
291 -> SignalMap -- | the signals in which to store the function result
292 -> Entity -- | The entity to map against.
293 -> [AST.AssocElem] -- | The resulting port maps
295 mkAssocElems sigmap args res entity =
296 -- Create the actual AssocElems
297 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
299 -- Turn the ports and signals from a map into a flat list. This works,
300 -- since the maps must have an identical form by definition. TODO: Check
302 arg_ports = concat (map Foldable.toList (ent_args entity))
303 res_ports = Foldable.toList (ent_res entity)
304 arg_sigs = (concat (map Foldable.toList args))
305 res_sigs = Foldable.toList res
306 -- Extract the id part from the (id, type) tuple
307 ports = (map (fmap fst) (arg_ports ++ res_ports))
308 -- Translate signal numbers into names
309 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
311 -- | Look up a signal in the signal name map
312 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
313 lookupSigName sigs sig = name
315 info = Maybe.fromMaybe
316 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
318 name = Maybe.fromMaybe
319 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
322 -- | Create an VHDL port -> signal association
323 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
324 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
325 mkAssocElem Nothing _ = Nothing
327 -- | The VHDL Bit type
328 bit_ty :: AST.TypeMark
329 bit_ty = AST.unsafeVHDLBasicId "Bit"
331 -- | The VHDL Boolean type
332 bool_ty :: AST.TypeMark
333 bool_ty = AST.unsafeVHDLBasicId "Boolean"
335 -- | The VHDL std_logic
336 std_logic_ty :: AST.TypeMark
337 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
339 -- Translate a Haskell type to a VHDL type
340 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
343 let builtin_ty = do -- See if this is a tycon and lookup its name
344 (tycon, args) <- Type.splitTyConApp_maybe ty
345 let name = Name.getOccString (TyCon.tyConName tycon)
346 Map.lookup name builtin_types
347 -- If not a builtin type, try the custom types
348 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
349 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
350 -- Found a type, return it
352 -- No type yet, try to construct it
355 -- Use the Maybe Monad for failing when one of these fails
356 (tycon, args) <- Type.splitTyConApp_maybe ty
357 let name = Name.getOccString (TyCon.tyConName tycon)
359 "FSVec" -> Just $ mk_fsvec_ty ty args
361 -- Return new_ty when a new type was successfully created
363 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
366 -- | Create a VHDL type belonging to a FSVec Haskell type
368 Type.Type -- ^ The Haskell type to create a VHDL type for
369 -> [Type.Type] -- ^ Type arguments to the FSVec type constructor
370 -> TypeState AST.TypeMark -- The typemark created.
372 mk_fsvec_ty ty args = do
373 -- Assume there are two type arguments
374 let [len, el_ty] = args
375 let len_int = eval_type_level_int len
376 let ty_id = mkVHDLId $ "vector_" ++ (show len_int)
378 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len_int - 1))]
379 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
380 let ty_dec = AST.TypeDec ty_id ty_def
381 -- TODO: Check name uniqueness
382 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
388 ("Bit", std_logic_ty),
389 ("Bool", bool_ty) -- TysWiredIn.boolTy
393 mkVHDLId :: String -> AST.VHDLId
395 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
397 -- Strip invalid characters.
398 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
399 -- Strip multiple adjacent underscores
400 strip_multiscore = concat . map (\cs ->
406 -- | A consise representation of a (set of) ports on a builtin function
407 type PortMap = HsValueMap (String, AST.TypeMark)
408 -- | A consise representation of a builtin function
409 data BuiltIn = BuiltIn String [PortMap] PortMap
411 -- | Translate a list of concise representation of builtin functions to a
413 mkBuiltins :: [BuiltIn] -> SignatureMap
414 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
415 (HsFunction name (map useAsPort args) (useAsPort res),
416 Entity (VHDL.mkVHDLId name) (map toVHDLSignalMap args) (toVHDLSignalMap res))
419 builtin_hsfuncs = Map.keys builtin_funcs
420 builtin_funcs = mkBuiltins
422 BuiltIn "hwxor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
423 BuiltIn "hwand" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
424 BuiltIn "hwor" [(Single ("a", VHDL.bit_ty)), (Single ("b", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty)),
425 BuiltIn "hwnot" [(Single ("a", VHDL.bit_ty))] (Single ("o", VHDL.bit_ty))
428 -- | Map a port specification of a builtin function to a VHDL Signal to put in
430 toVHDLSignalMap :: HsValueMap (String, AST.TypeMark) -> VHDLSignalMap
431 toVHDLSignalMap = fmap (\(name, ty) -> Just (mkVHDLId name, ty))
433 -- vim: set ts=8 sw=2 sts=2 expandtab: