2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
7 import qualified Data.List as List
9 import qualified Control.Monad as Monad
10 import qualified Control.Arrow as Arrow
11 import qualified Data.Traversable as Traversable
12 import qualified Data.Monoid as Monoid
15 import qualified TysWiredIn
17 import qualified TyCon
18 import Outputable ( showSDoc, ppr )
20 import qualified ForSyDe.Backend.VHDL.AST as AST
25 import TranslatorTypes
28 getDesignFiles :: [FuncData] -> [AST.DesignFile]
29 getDesignFiles funcs =
30 map (AST.DesignFile context) units
32 units = filter (not.null) $ map getLibraryUnits funcs
34 AST.Library $ mkVHDLId "IEEE",
35 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
37 -- | Create an entity for a given function
39 HsFunction -- | The function signature
40 -> FuncData -- | The function data collected so far
41 -> Maybe Entity -- | The resulting entity. Should return the existing
42 --- Entity for builtin functions.
44 createEntity hsfunc fdata =
45 case flatFunc fdata of
46 -- Skip (builtin) functions without a FlatFunction
47 Nothing -> funcEntity fdata
48 -- Create an entity for all other functions
51 sigs = flat_sigs flatfunc
52 args = flat_args flatfunc
53 res = flat_res flatfunc
54 (ty_decls, args') = Traversable.traverse (Traversable.traverse (mkMap sigs)) args
55 (ty_decls', res') = Traversable.traverse (mkMap sigs) res
56 -- TODO: Unique ty_decls
57 ent_decl' = createEntityAST hsfunc args' res'
58 pkg_id = mkVHDLId $ (AST.fromVHDLId entity_id) ++ "_types"
59 pkg_decl = if null ty_decls && null ty_decls'
61 else Just $ AST.PackageDec pkg_id (map AST.PDITD $ ty_decls ++ ty_decls')
62 AST.EntityDec entity_id _ = ent_decl'
64 Just $ Entity entity_id args' res' (Just ent_decl') pkg_decl
67 [(SignalId, SignalInfo)]
69 -> ([AST.TypeDec], Maybe (AST.VHDLId, AST.TypeMark))
71 if isPortSigUse $ sigUse info
73 let (decs, type_mark) = vhdl_ty ty in
74 (decs, Just (mkVHDLId nm, type_mark))
76 (Monoid.mempty, Nothing)
78 info = Maybe.fromMaybe
79 (error $ "Signal not found in the name map? This should not happen!")
82 (error $ "Signal not named? This should not happen!")
86 -- | Create the VHDL AST for an entity
88 HsFunction -- | The signature of the function we're working with
89 -> [VHDLSignalMap] -- | The entity's arguments
90 -> VHDLSignalMap -- | The entity's result
91 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
93 createEntityAST hsfunc args res =
94 AST.EntityDec vhdl_id ports
96 vhdl_id = mkEntityId hsfunc
97 ports = concatMap (mapToPorts AST.In) args
98 ++ mapToPorts AST.Out res
100 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
102 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
103 -- Add a clk port if we have state
104 clk_port = if hasState hsfunc
106 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
110 -- | Create a port declaration
112 AST.Mode -- | The mode for the port (In / Out)
113 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
114 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
116 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
117 mkIfaceSigDec _ Nothing = Nothing
119 -- | Generate a VHDL entity name for the given hsfunc
121 -- TODO: This doesn't work for functions with multiple signatures!
122 mkVHDLId $ hsFuncName hsfunc
124 -- | Create an architecture for a given function
125 createArchitecture ::
126 HsFunction -- | The function signature
127 -> FuncData -- | The function data collected so far
130 createArchitecture hsfunc fdata =
131 let func = flatFunc fdata in
133 -- Skip (builtin) functions without a FlatFunction
134 Nothing -> do return ()
135 -- Create an architecture for all other functions
137 let sigs = flat_sigs flatfunc
138 let args = flat_args flatfunc
139 let res = flat_res flatfunc
140 let defs = flat_defs flatfunc
141 let entity_id = Maybe.fromMaybe
142 (error $ "Building architecture without an entity? This should not happen!")
144 -- Create signal declarations for all signals that are not in args and
146 let (ty_decls, sig_decs) = Arrow.second Maybe.catMaybes $ Traversable.traverse (mkSigDec . snd) sigs
147 -- TODO: Unique ty_decls
148 -- TODO: Store ty_decls somewhere
149 -- Create concurrent statements for all signal definitions
150 statements <- mapM (mkConcSm sigs) defs
151 let procs = map mkStateProcSm (makeStatePairs flatfunc)
152 let procs' = map AST.CSPSm procs
153 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
154 setArchitecture hsfunc arch
156 -- | Looks up all pairs of old state, new state signals, together with
157 -- the state id they represent.
158 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
159 makeStatePairs flatfunc =
160 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
161 | old_info <- map snd (flat_sigs flatfunc)
162 , new_info <- map snd (flat_sigs flatfunc)
163 -- old_info must be an old state (and, because of the next equality,
164 -- new_info must be a new state).
165 , Maybe.isJust $ oldStateId $ sigUse old_info
166 -- And the state numbers must match
167 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
169 -- Replace the second tuple element with the corresponding SignalInfo
170 --args_states = map (Arrow.second $ signalInfo sigs) args
171 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
172 mkStateProcSm (num, old, new) =
173 AST.ProcSm label [clk] [statement]
175 label = mkVHDLId $ "state_" ++ (show num)
177 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
178 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
179 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
180 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
181 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
183 mkSigDec :: SignalInfo -> ([AST.TypeDec], Maybe AST.SigDec)
185 let use = sigUse info in
186 if isInternalSigUse use || isStateSigUse use then
187 let (ty_decls, type_mark) = vhdl_ty ty in
188 (ty_decls, Just $ AST.SigDec (getSignalId info) type_mark Nothing)
194 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
196 getSignalId :: SignalInfo -> AST.VHDLId
198 mkVHDLId $ Maybe.fromMaybe
199 (error $ "Unnamed signal? This should not happen!")
202 -- | Transforms a signal definition into a VHDL concurrent statement
204 [(SignalId, SignalInfo)] -- | The signals in the current architecture
205 -> SigDef -- | The signal definition
206 -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation.
208 mkConcSm sigs (FApp hsfunc args res) = do
209 fdata_maybe <- getFunc hsfunc
210 let fdata = Maybe.fromMaybe
211 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
213 let entity = Maybe.fromMaybe
214 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
216 let entity_id = ent_id entity
217 label <- uniqueName (AST.fromVHDLId entity_id)
218 -- Add a clk port if we have state
219 let clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLId "clk") "clk"
220 let portmaps = mkAssocElems sigs args res entity ++ (if hasState hsfunc then [clk_port] else [])
221 return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
223 mkConcSm sigs (UncondDef src dst) = do
224 let src_expr = vhdl_expr src
225 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
226 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
227 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
228 return $ AST.CSSASm assign
230 vhdl_expr (Left id) = mkIdExpr sigs id
231 vhdl_expr (Right expr) =
234 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
238 (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
240 mkConcSm sigs (CondDef cond true false dst) = do
241 let cond_expr = mkIdExpr sigs cond
242 let true_expr = mkIdExpr sigs true
243 let false_expr = mkIdExpr sigs false
244 let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
245 let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
246 let whenelse = AST.WhenElse true_wform cond_expr
247 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
248 let assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
249 return $ AST.CSSASm assign
251 -- | Turn a SignalId into a VHDL Expr
252 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
254 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
255 AST.PrimName src_name
258 [(SignalId, SignalInfo)] -- | The signals in the current architecture
259 -> [SignalMap] -- | The signals that are applied to function
260 -> SignalMap -- | the signals in which to store the function result
261 -> Entity -- | The entity to map against.
262 -> [AST.AssocElem] -- | The resulting port maps
264 mkAssocElems sigmap args res entity =
265 -- Create the actual AssocElems
266 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
268 -- Turn the ports and signals from a map into a flat list. This works,
269 -- since the maps must have an identical form by definition. TODO: Check
271 arg_ports = concat (map Foldable.toList (ent_args entity))
272 res_ports = Foldable.toList (ent_res entity)
273 arg_sigs = (concat (map Foldable.toList args))
274 res_sigs = Foldable.toList res
275 -- Extract the id part from the (id, type) tuple
276 ports = (map (fmap fst) (arg_ports ++ res_ports))
277 -- Translate signal numbers into names
278 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
280 -- | Look up a signal in the signal name map
281 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
282 lookupSigName sigs sig = name
284 info = Maybe.fromMaybe
285 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
287 name = Maybe.fromMaybe
288 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
291 -- | Create an VHDL port -> signal association
292 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
293 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
294 mkAssocElem Nothing _ = Nothing
296 -- | Extracts the generated entity id from the given funcdata
297 getEntityId :: FuncData -> Maybe AST.VHDLId
299 case funcEntity fdata of
301 Just e -> case ent_decl e of
303 Just (AST.EntityDec id _) -> Just id
306 FuncData -- | A function from the session
307 -> [AST.LibraryUnit] -- | The entity, architecture and optional package for the function
309 getLibraryUnits fdata =
310 case funcEntity fdata of
316 case funcArch fdata of
319 [AST.LUEntity decl, AST.LUArch arch]
320 ++ (Maybe.maybeToList (fmap AST.LUPackageDec $ ent_pkg_decl ent))
322 -- | The VHDL Bit type
323 bit_ty :: AST.TypeMark
324 bit_ty = AST.unsafeVHDLBasicId "Bit"
326 -- | The VHDL Boolean type
327 bool_ty :: AST.TypeMark
328 bool_ty = AST.unsafeVHDLBasicId "Boolean"
330 -- | The VHDL std_logic
331 std_logic_ty :: AST.TypeMark
332 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
334 -- Translate a Haskell type to a VHDL type
335 vhdl_ty :: Type.Type -> ([AST.TypeDec], AST.TypeMark)
336 vhdl_ty ty = Maybe.fromMaybe
337 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
340 -- Translate a Haskell type to a VHDL type, optionally generating a type
341 -- declaration for the type.
342 vhdl_ty_maybe :: Type.Type -> Maybe ([AST.TypeDec], AST.TypeMark)
344 if Type.coreEqType ty TysWiredIn.boolTy
348 case Type.splitTyConApp_maybe ty of
349 Just (tycon, args) ->
350 let name = TyCon.tyConName tycon in
351 -- TODO: Do something more robust than string matching
352 case Name.getOccString name of
353 "Bit" -> Just ([], std_logic_ty)
357 -- TODO: Find actual number
358 ty_id = mkVHDLId ("vector_" ++ (show len))
360 range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "16")]
361 ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
362 ty_dec = AST.TypeDec ty_id ty_def
364 Just ([ty_dec], ty_id)
369 mkVHDLId :: String -> AST.VHDLId
371 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_invalid) s
373 -- Strip invalid characters.
374 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
375 -- Strip multiple adjacent underscores
376 strip_multiscore = concat . map (\cs ->