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
29 return $ AST.DesignFile
33 -- | Create an entity for a given function
35 HsFunction -- | The function signature
36 -> FuncData -- | The function data collected so far
39 createEntity hsfunc fdata =
40 let func = flatFunc fdata in
42 -- Skip (builtin) functions without a FlatFunction
43 Nothing -> do return ()
44 -- Create an entity for all other functions
48 sigs = flat_sigs flatfunc
49 args = flat_args flatfunc
50 res = flat_res flatfunc
51 args' = map (fmap (mkMap sigs)) args
52 res' = fmap (mkMap sigs) res
53 ent_decl' = createEntityAST hsfunc args' res'
54 AST.EntityDec entity_id _ = ent_decl'
55 entity' = Entity entity_id args' res' (Just ent_decl')
57 setEntity hsfunc entity'
59 mkMap :: Eq id => [(id, SignalInfo)] -> id -> (AST.VHDLId, AST.TypeMark)
61 (mkVHDLId nm, vhdl_ty ty)
63 info = Maybe.fromMaybe
64 (error $ "Signal not found in the name map? This should not happen!")
67 (error $ "Signal not named? This should not happen!")
71 -- | Create the VHDL AST for an entity
73 HsFunction -- | The signature of the function we're working with
74 -> [VHDLSignalMap] -- | The entity's arguments
75 -> VHDLSignalMap -- | The entity's result
76 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
78 createEntityAST hsfunc args res =
79 AST.EntityDec vhdl_id ports
81 vhdl_id = mkEntityId hsfunc
82 ports = concatMap (mapToPorts AST.In) args
83 ++ mapToPorts AST.Out res
85 mapToPorts :: AST.Mode -> VHDLSignalMap -> [AST.IfaceSigDec]
87 map (mkIfaceSigDec mode) (Foldable.toList m)
88 -- Add a clk port if we have state
89 clk_port = if hasState hsfunc
91 [AST.IfaceSigDec (mkVHDLId "clk") AST.In VHDL.std_logic_ty]
95 -- | Create a port declaration
97 AST.Mode -- | The mode for the port (In / Out)
98 -> (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
99 -> AST.IfaceSigDec -- | The resulting port declaration
101 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
103 -- | Generate a VHDL entity name for the given hsfunc
105 -- TODO: This doesn't work for functions with multiple signatures!
106 mkVHDLId $ hsFuncName hsfunc
108 -- | Create an architecture for a given function
109 createArchitecture ::
110 HsFunction -- | The function signature
111 -> FuncData -- | The function data collected so far
114 createArchitecture hsfunc fdata =
115 let func = flatFunc fdata in
117 -- Skip (builtin) functions without a FlatFunction
118 Nothing -> do return ()
119 -- Create an architecture for all other functions
121 let sigs = flat_sigs flatfunc
122 let args = flat_args flatfunc
123 let res = flat_res flatfunc
124 let apps = flat_apps flatfunc
125 let entity_id = Maybe.fromMaybe
126 (error $ "Building architecture without an entity? This should not happen!")
128 -- Create signal declarations for all signals that are not in args and
130 let sig_decs = [mkSigDec info | (id, info) <- sigs, (all (id `Foldable.notElem`) (res:args)) ]
131 -- Create component instantiations for all function applications
132 insts <- mapM (mkCompInsSm sigs) apps
133 let procs = map mkStateProcSm (getOwnStates hsfunc flatfunc)
134 let insts' = map AST.CSISm insts
135 let procs' = map AST.CSPSm procs
136 let arch = AST.ArchBody (mkVHDLId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (insts' ++ procs')
137 setArchitecture hsfunc arch
139 mkStateProcSm :: (Int, SignalInfo, SignalInfo) -> AST.ProcSm
140 mkStateProcSm (num, old, new) =
141 AST.ProcSm label [clk] [statement]
143 label = mkVHDLId $ "state_" ++ (show num)
145 rising_edge = AST.NSimple $ mkVHDLId "rising_edge"
146 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
147 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
148 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
149 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
151 mkSigDec :: SignalInfo -> AST.SigDec
153 AST.SigDec (getSignalId info) (vhdl_ty ty) Nothing
157 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
159 getSignalId :: SignalInfo -> AST.VHDLId
161 mkVHDLId $ Maybe.fromMaybe
162 (error $ "Unnamed signal? This should not happen!")
165 -- | Transforms a flat function application to a VHDL component instantiation.
167 [(UnnamedSignal, SignalInfo)] -- | The signals in the current architecture
168 -> FApp UnnamedSignal -- | The application to look at.
169 -> VHDLState AST.CompInsSm -- | The corresponding VHDL component instantiation.
171 mkCompInsSm sigs app = do
172 let hsfunc = appFunc app
173 fdata_maybe <- getFunc hsfunc
174 let fdata = Maybe.fromMaybe
175 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' that is not in the session? This should not happen!")
177 let entity = Maybe.fromMaybe
178 (error $ "Using function '" ++ (prettyShow hsfunc) ++ "' without entity declaration? This should not happen!")
180 let entity_id = ent_id entity
181 label <- uniqueName (AST.fromVHDLId entity_id)
182 let portmaps = mkAssocElems sigs app entity
183 return $ AST.CompInsSm (mkVHDLId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
186 [(UnnamedSignal, SignalInfo)] -- | The signals in the current architecture
187 -> FApp UnnamedSignal -- | The application to look at.
188 -> Entity -- | The entity to map against.
189 -> [AST.AssocElem] -- | The resulting port maps
191 mkAssocElems sigmap app entity =
192 -- Create the actual AssocElems
193 zipWith mkAssocElem ports sigs
195 -- Turn the ports and signals from a map into a flat list. This works,
196 -- since the maps must have an identical form by definition. TODO: Check
198 arg_ports = concat (map Foldable.toList (ent_args entity))
199 res_ports = Foldable.toList (ent_res entity)
200 arg_sigs = (concat (map Foldable.toList (appArgs app)))
201 res_sigs = Foldable.toList (appRes app)
202 -- Extract the id part from the (id, type) tuple
203 ports = (map fst (arg_ports ++ res_ports))
204 -- Translate signal numbers into names
205 sigs = (map (lookupSigName sigmap) (arg_sigs ++ res_sigs))
207 -- | Look up a signal in the signal name map
208 lookupSigName :: [(UnnamedSignal, SignalInfo)] -> UnnamedSignal -> String
209 lookupSigName sigs sig = name
211 info = Maybe.fromMaybe
212 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
214 name = Maybe.fromMaybe
215 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
218 -- | Create an VHDL port -> signal association
219 mkAssocElem :: AST.VHDLId -> String -> AST.AssocElem
220 mkAssocElem port signal = Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLId signal)))
222 -- | Extracts the generated entity id from the given funcdata
223 getEntityId :: FuncData -> Maybe AST.VHDLId
225 case funcEntity fdata of
227 Just e -> case ent_decl e of
229 Just (AST.EntityDec id _) -> Just id
232 (HsFunction, FuncData) -- | A function from the session
233 -> [AST.LibraryUnit] -- | The library units it generates
235 getLibraryUnits (hsfunc, fdata) =
236 case funcEntity fdata of
238 Just ent -> case ent_decl ent of
240 Just decl -> [AST.LUEntity decl]
242 case funcArch fdata of
244 Just arch -> [AST.LUArch arch]
246 -- | The VHDL Bit type
247 bit_ty :: AST.TypeMark
248 bit_ty = AST.unsafeVHDLBasicId "Bit"
250 -- | The VHDL std_logic
251 std_logic_ty :: AST.TypeMark
252 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
254 -- Translate a Haskell type to a VHDL type
255 vhdl_ty :: Type.Type -> AST.TypeMark
256 vhdl_ty ty = Maybe.fromMaybe
257 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
260 -- Translate a Haskell type to a VHDL type
261 vhdl_ty_maybe :: Type.Type -> Maybe AST.TypeMark
263 case Type.splitTyConApp_maybe ty of
264 Just (tycon, args) ->
265 let name = TyCon.tyConName tycon in
266 -- TODO: Do something more robust than string matching
267 case Name.getOccString name of
273 mkVHDLId :: String -> AST.VHDLId
274 mkVHDLId = AST.unsafeVHDLBasicId