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)
196 [(SignalId, SignalInfo)] -- | The signals in the current architecture
197 -> [SignalMap] -- | The signals that are applied to function
198 -> SignalMap -- | the signals in which to store the function result
199 -> Entity -- | The entity to map against.
200 -> [AST.AssocElem] -- | The resulting port maps
202 mkAssocElems sigmap args res entity =
203 -- Create the actual AssocElems
204 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
206 -- Turn the ports and signals from a map into a flat list. This works,
207 -- since the maps must have an identical form by definition. TODO: Check
209 arg_ports = concat (map Foldable.toList (ent_args entity))
210 res_ports = Foldable.toList (ent_res entity)
211 arg_sigs = (concat (map Foldable.toList args))
212 res_sigs = Foldable.toList res
213 -- Extract the id part from the (id, type) tuple
214 ports = (map (fmap fst) (arg_ports ++ res_ports))
215 -- Translate signal numbers into names
216 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
218 -- | Look up a signal in the signal name map
219 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
220 lookupSigName sigs sig = name
222 info = Maybe.fromMaybe
223 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
225 name = Maybe.fromMaybe
226 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
229 -- | Create an VHDL port -> signal association
230 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
231 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
232 mkAssocElem Nothing _ = Nothing
234 -- | Extracts the generated entity id from the given funcdata
235 getEntityId :: FuncData -> Maybe AST.VHDLId
237 case funcEntity fdata of
239 Just e -> case ent_decl e of
241 Just (AST.EntityDec id _) -> Just id
244 (HsFunction, FuncData) -- | A function from the session
245 -> [AST.LibraryUnit] -- | The library units it generates
247 getLibraryUnits (hsfunc, fdata) =
248 case funcEntity fdata of
250 Just ent -> case ent_decl ent of
252 Just decl -> [AST.LUEntity decl]
254 case funcArch fdata of
256 Just arch -> [AST.LUArch arch]
258 -- | The VHDL Bit type
259 bit_ty :: AST.TypeMark
260 bit_ty = AST.unsafeVHDLBasicId "Bit"
262 -- | The VHDL std_logic
263 std_logic_ty :: AST.TypeMark
264 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
266 -- Translate a Haskell type to a VHDL type
267 vhdl_ty :: Type.Type -> AST.TypeMark
268 vhdl_ty ty = Maybe.fromMaybe
269 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
272 -- Translate a Haskell type to a VHDL type
273 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
275 case Type.splitTyConApp_maybe ty of
276 Just (tycon, args) ->
277 let name = TyCon.tyConName tycon in
278 -- TODO: Do something more robust than string matching
279 case Name.getOccString name of
285 mkVHDLId :: String -> AST.VHDLId
286 mkVHDLId = AST.unsafeVHDLBasicId