2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
8 import qualified Control.Monad as Monad
11 import qualified TysWiredIn
13 import qualified TyCon
14 import Outputable ( showSDoc, ppr )
16 import qualified ForSyDe.Backend.VHDL.AST as AST
21 import TranslatorTypes
24 getDesignFile :: VHDLState AST.DesignFile
26 -- Extract the library units generated from all the functions in the
29 let units = concat $ map getLibraryUnits funcs
31 AST.Library $ mkVHDLId "IEEE",
32 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
33 return $ AST.DesignFile
37 -- | Create an entity for a given function
39 HsFunction -- | The function signature
40 -> FuncData -- | The function data collected so far
43 createEntity hsfunc fdata =
44 let func = flatFunc fdata in
46 -- Skip (builtin) functions without a FlatFunction
47 Nothing -> do return ()
48 -- Create an entity for all other functions
52 sigs = flat_sigs flatfunc
53 args = flat_args flatfunc
54 res = flat_res flatfunc
55 args' = map (fmap (mkMap sigs)) args
56 res' = fmap (mkMap sigs) res
57 ent_decl' = createEntityAST hsfunc args' res'
58 AST.EntityDec entity_id _ = ent_decl'
59 entity' = Entity entity_id args' res' (Just ent_decl')
61 setEntity hsfunc entity'
63 mkMap :: Eq id => [(id, SignalInfo)] -> id -> Maybe (AST.VHDLId, AST.TypeMark)
65 if isPortSigUse $ sigUse info
67 Just (mkVHDLId nm, vhdl_ty ty)
71 info = Maybe.fromMaybe
72 (error $ "Signal not found in the name map? This should not happen!")
75 (error $ "Signal not named? This should not happen!")
79 -- | Create the VHDL AST for an entity
81 HsFunction -- | The signature of the function we're working with
82 -> [VHDLSignalMap] -- | The entity's arguments
83 -> VHDLSignalMap -- | The entity's result
84 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
86 createEntityAST hsfunc args res =
87 AST.EntityDec vhdl_id ports
89 vhdl_id = mkEntityId hsfunc
90 ports = concatMap (mapToPorts AST.In) args
91 ++ mapToPorts AST.Out res
93 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
95 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
96 -- Add a clk port if we have state
97 clk_port = if hasState hsfunc
99 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
103 -- | Create a port declaration
105 AST.Mode -- | The mode for the port (In / Out)
106 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
107 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
109 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
110 mkIfaceSigDec _ Nothing = Nothing
112 -- | Generate a VHDL entity name for the given hsfunc
114 -- TODO: This doesn't work for functions with multiple signatures!
115 mkVHDLId $ hsFuncName hsfunc
117 -- | Create an architecture for a given function
118 createArchitecture ::
119 HsFunction -- | The function signature
120 -> FuncData -- | The function data collected so far
123 createArchitecture hsfunc fdata =
124 let func = flatFunc fdata in
126 -- Skip (builtin) functions without a FlatFunction
127 Nothing -> do return ()
128 -- Create an architecture for all other functions
130 let sigs = flat_sigs flatfunc
131 let args = flat_args flatfunc
132 let res = flat_res flatfunc
133 let defs = flat_defs flatfunc
134 let entity_id = Maybe.fromMaybe
135 (error $ "Building architecture without an entity? This should not happen!")
137 -- Create signal declarations for all signals that are not in args and
139 let sig_decs = Maybe.catMaybes $ map (mkSigDec . snd) sigs
140 -- Create concurrent statements for all signal definitions
141 statements <- mapM (mkConcSm sigs) defs
142 let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
143 let procs' = map AST.CSPSm procs
144 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
145 setArchitecture hsfunc arch
147 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
148 mkStateProcSm (num, old, new) =
149 AST.ProcSm label [clk] [statement]
151 label = mkVHDLId $ "state_" ++ (show num)
153 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
154 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
155 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
156 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
157 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
159 mkSigDec :: SignalInfo -> Maybe AST.SigDec
161 let use = sigUse info in
162 if isInternalSigUse use || isStateSigUse use then
163 Just $ AST.SigDec (getSignalId info) (vhdl_ty ty) Nothing
169 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
171 getSignalId :: SignalInfo -> AST.VHDLId
173 mkVHDLId $ Maybe.fromMaybe
174 (error $ "Unnamed signal? This should not happen!")
177 -- | Transforms a signal definition into a VHDL concurrent statement
179 [(SignalId, SignalInfo)] -- | The signals in the current architecture
180 -> SigDef -- | The signal definition
181 -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation.
183 mkConcSm sigs (FApp hsfunc args res) = do
184 fdata_maybe <- getFunc hsfunc
185 let fdata = Maybe.fromMaybe
186 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
188 let entity = Maybe.fromMaybe
189 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
191 let entity_id = ent_id entity
192 label <- uniqueName (AST.fromVHDLId entity_id)
193 let portmaps = mkAssocElems sigs args res entity
194 return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
196 mkConcSm sigs (UncondDef src dst) = do
197 let src_expr = vhdl_expr src
198 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
199 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
200 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
201 return $ AST.CSSASm assign
203 vhdl_expr (Left id) = mkIdExpr sigs id
204 vhdl_expr (Right expr) =
207 (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
209 mkConcSm sigs (CondDef cond true false dst) = do
210 let cond_expr = mkIdExpr sigs cond
211 let true_expr = mkIdExpr sigs true
212 let false_expr = mkIdExpr sigs false
213 let false_wform = AST.Wform [AST.WformElem false_expr Nothing]
214 let true_wform = AST.Wform [AST.WformElem true_expr Nothing]
215 let whenelse = AST.WhenElse true_wform cond_expr
216 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
217 let assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
218 return $ AST.CSSASm assign
220 -- | Turn a SignalId into a VHDL Expr
221 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
223 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
224 AST.PrimName src_name
227 [(SignalId, SignalInfo)] -- | The signals in the current architecture
228 -> [SignalMap] -- | The signals that are applied to function
229 -> SignalMap -- | the signals in which to store the function result
230 -> Entity -- | The entity to map against.
231 -> [AST.AssocElem] -- | The resulting port maps
233 mkAssocElems sigmap args res entity =
234 -- Create the actual AssocElems
235 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
237 -- Turn the ports and signals from a map into a flat list. This works,
238 -- since the maps must have an identical form by definition. TODO: Check
240 arg_ports = concat (map Foldable.toList (ent_args entity))
241 res_ports = Foldable.toList (ent_res entity)
242 arg_sigs = (concat (map Foldable.toList args))
243 res_sigs = Foldable.toList res
244 -- Extract the id part from the (id, type) tuple
245 ports = (map (fmap fst) (arg_ports ++ res_ports))
246 -- Translate signal numbers into names
247 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
249 -- | Look up a signal in the signal name map
250 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
251 lookupSigName sigs sig = name
253 info = Maybe.fromMaybe
254 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
256 name = Maybe.fromMaybe
257 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
260 -- | Create an VHDL port -> signal association
261 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
262 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
263 mkAssocElem Nothing _ = Nothing
265 -- | Extracts the generated entity id from the given funcdata
266 getEntityId :: FuncData -> Maybe AST.VHDLId
268 case funcEntity fdata of
270 Just e -> case ent_decl e of
272 Just (AST.EntityDec id _) -> Just id
275 (HsFunction, FuncData) -- | A function from the session
276 -> [AST.LibraryUnit] -- | The library units it generates
278 getLibraryUnits (hsfunc, fdata) =
279 case funcEntity fdata of
281 Just ent -> case ent_decl ent of
283 Just decl -> [AST.LUEntity decl]
285 case funcArch fdata of
287 Just arch -> [AST.LUArch arch]
289 -- | The VHDL Bit type
290 bit_ty :: AST.TypeMark
291 bit_ty = AST.unsafeVHDLBasicId "Bit"
293 -- | The VHDL Boolean type
294 bool_ty :: AST.TypeMark
295 bool_ty = AST.unsafeVHDLBasicId "Boolean"
297 -- | The VHDL std_logic
298 std_logic_ty :: AST.TypeMark
299 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
301 -- Translate a Haskell type to a VHDL type
302 vhdl_ty :: Type.Type -> AST.TypeMark
303 vhdl_ty ty = Maybe.fromMaybe
304 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
307 -- Translate a Haskell type to a VHDL type
308 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
310 if Type.coreEqType ty TysWiredIn.boolTy
314 case Type.splitTyConApp_maybe ty of
315 Just (tycon, args) ->
316 let name = TyCon.tyConName tycon in
317 -- TODO: Do something more robust than string matching
318 case Name.getOccString name of
324 mkVHDLId :: String -> AST.VHDLId
325 mkVHDLId = AST.unsafeVHDLBasicId