2 -- Functions to generate VHDL from FlatFunctions
6 import qualified Data.Foldable as Foldable
8 import qualified Control.Monad as Monad
12 import qualified TyCon
13 import Outputable ( showSDoc, ppr )
15 import qualified ForSyDe.Backend.VHDL.AST as AST
20 import TranslatorTypes
23 getDesignFile :: VHDLState AST.DesignFile
25 -- Extract the library units generated from all the functions in the
28 let units = concat $ map getLibraryUnits funcs
30 AST.Library $ mkVHDLId "IEEE",
31 AST.Use $ (AST.NSimple $ mkVHDLId "IEEE.std_logic_1164") AST.:.: AST.All]
32 return $ AST.DesignFile
36 -- | Create an entity for a given function
38 HsFunction -- | The function signature
39 -> FuncData -- | The function data collected so far
42 createEntity hsfunc fdata =
43 let func = flatFunc fdata in
45 -- Skip (builtin) functions without a FlatFunction
46 Nothing -> do return ()
47 -- Create an entity for all other functions
51 sigs = flat_sigs flatfunc
52 args = flat_args flatfunc
53 res = flat_res flatfunc
54 args' = map (fmap (mkMap sigs)) args
55 res' = fmap (mkMap sigs) res
56 ent_decl' = createEntityAST hsfunc args' res'
57 AST.EntityDec entity_id _ = ent_decl'
58 entity' = Entity entity_id args' res' (Just ent_decl')
60 setEntity hsfunc entity'
62 mkMap :: Eq id => [(id, SignalInfo)] -> id -> Maybe (AST.VHDLId, AST.TypeMark)
64 if isPortSigUse $ sigUse info
66 Just (mkVHDLId nm, vhdl_ty ty)
70 info = Maybe.fromMaybe
71 (error $ "Signal not found in the name map? This should not happen!")
74 (error $ "Signal not named? This should not happen!")
78 -- | Create the VHDL AST for an entity
80 HsFunction -- | The signature of the function we're working with
81 -> [VHDLSignalMap] -- | The entity's arguments
82 -> VHDLSignalMap -- | The entity's result
83 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
85 createEntityAST hsfunc args res =
86 AST.EntityDec vhdl_id ports
88 vhdl_id = mkEntityId hsfunc
89 ports = concatMap (mapToPorts AST.In) args
90 ++ mapToPorts AST.Out res
92 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
94 Maybe.catMaybes $ map (mkIfaceSigDec mode) (Foldable.toList m)
95 -- Add a clk port if we have state
96 clk_port = if hasState hsfunc
98 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
102 -- | Create a port declaration
104 AST.Mode -- | The mode for the port (In / Out)
105 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
106 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
108 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
109 mkIfaceSigDec _ Nothing = Nothing
111 -- | Generate a VHDL entity name for the given hsfunc
113 -- TODO: This doesn't work for functions with multiple signatures!
114 mkVHDLId $ hsFuncName hsfunc
116 -- | Create an architecture for a given function
117 createArchitecture ::
118 HsFunction -- | The function signature
119 -> FuncData -- | The function data collected so far
122 createArchitecture hsfunc fdata =
123 let func = flatFunc fdata in
125 -- Skip (builtin) functions without a FlatFunction
126 Nothing -> do return ()
127 -- Create an architecture for all other functions
129 let sigs = flat_sigs flatfunc
130 let args = flat_args flatfunc
131 let res = flat_res flatfunc
132 let defs = flat_defs flatfunc
133 let entity_id = Maybe.fromMaybe
134 (error $ "Building architecture without an entity? This should not happen!")
136 -- Create signal declarations for all signals that are not in args and
138 let sig_decs = Maybe.catMaybes $ map (mkSigDec . snd) sigs
139 -- Create concurrent statements for all signal definitions
140 statements <- mapM (mkConcSm sigs) defs
141 let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
142 let procs' = map AST.CSPSm procs
143 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
144 setArchitecture hsfunc arch
146 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
147 mkStateProcSm (num, old, new) =
148 AST.ProcSm label [clk] [statement]
150 label = mkVHDLId $ "state_" ++ (show num)
152 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
153 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
154 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
155 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
156 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
158 mkSigDec :: SignalInfo -> Maybe AST.SigDec
160 let use = sigUse info in
161 if isInternalSigUse use || isStateSigUse use then
162 Just $ AST.SigDec (getSignalId info) (vhdl_ty ty) Nothing
168 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
170 getSignalId :: SignalInfo -> AST.VHDLId
172 mkVHDLId $ Maybe.fromMaybe
173 (error $ "Unnamed signal? This should not happen!")
176 -- | Transforms a signal definition into a VHDL concurrent statement
178 [(SignalId, SignalInfo)] -- | The signals in the current architecture
179 -> SigDef -- | The signal definition
180 -> VHDLState AST.ConcSm -- | The corresponding VHDL component instantiation.
182 mkConcSm sigs (FApp hsfunc args res) = do
183 fdata_maybe <- getFunc hsfunc
184 let fdata = Maybe.fromMaybe
185 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
187 let entity = Maybe.fromMaybe
188 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
190 let entity_id = ent_id entity
191 label <- uniqueName (AST.fromVHDLId entity_id)
192 let portmaps = mkAssocElems sigs args res entity
193 return $ AST.CSISm $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
195 mkConcSm sigs (UncondDef src dst) = do
196 let src_name = AST.NSimple (getSignalId $ signalInfo sigs src)
197 let src_expr = AST.PrimName src_name
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
204 [(SignalId, SignalInfo)] -- | The signals in the current architecture
205 -> [SignalMap] -- | The signals that are applied to function
206 -> SignalMap -- | the signals in which to store the function result
207 -> Entity -- | The entity to map against.
208 -> [AST.AssocElem] -- | The resulting port maps
210 mkAssocElems sigmap args res entity =
211 -- Create the actual AssocElems
212 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
214 -- Turn the ports and signals from a map into a flat list. This works,
215 -- since the maps must have an identical form by definition. TODO: Check
217 arg_ports = concat (map Foldable.toList (ent_args entity))
218 res_ports = Foldable.toList (ent_res entity)
219 arg_sigs = (concat (map Foldable.toList args))
220 res_sigs = Foldable.toList res
221 -- Extract the id part from the (id, type) tuple
222 ports = (map (fmap fst) (arg_ports ++ res_ports))
223 -- Translate signal numbers into names
224 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
226 -- | Look up a signal in the signal name map
227 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
228 lookupSigName sigs sig = name
230 info = Maybe.fromMaybe
231 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
233 name = Maybe.fromMaybe
234 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
237 -- | Create an VHDL port -> signal association
238 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
239 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
240 mkAssocElem Nothing _ = Nothing
242 -- | Extracts the generated entity id from the given funcdata
243 getEntityId :: FuncData -> Maybe AST.VHDLId
245 case funcEntity fdata of
247 Just e -> case ent_decl e of
249 Just (AST.EntityDec id _) -> Just id
252 (HsFunction, FuncData) -- | A function from the session
253 -> [AST.LibraryUnit] -- | The library units it generates
255 getLibraryUnits (hsfunc, fdata) =
256 case funcEntity fdata of
258 Just ent -> case ent_decl ent of
260 Just decl -> [AST.LUEntity decl]
262 case funcArch fdata of
264 Just arch -> [AST.LUArch arch]
266 -- | The VHDL Bit type
267 bit_ty :: AST.TypeMark
268 bit_ty = AST.unsafeVHDLBasicId "Bit"
270 -- | The VHDL std_logic
271 std_logic_ty :: AST.TypeMark
272 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
274 -- Translate a Haskell type to a VHDL type
275 vhdl_ty :: Type.Type -> AST.TypeMark
276 vhdl_ty ty = Maybe.fromMaybe
277 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
280 -- Translate a Haskell type to a VHDL type
281 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
283 case Type.splitTyConApp_maybe ty of
284 Just (tycon, args) ->
285 let name = TyCon.tyConName tycon in
286 -- TODO: Do something more robust than string matching
287 case Name.getOccString name of
293 mkVHDLId :: String -> AST.VHDLId
294 mkVHDLId = AST.unsafeVHDLBasicId