2 -- Functions to generate VHDL from FlatFunctions
7 import qualified Data.Foldable as Foldable
8 import qualified Data.List as List
9 import qualified Data.Map as Map
10 import qualified Maybe
11 import qualified Control.Monad as Monad
12 import qualified Control.Arrow as Arrow
13 import qualified Control.Monad.Trans.State as State
14 import qualified Data.Traversable as Traversable
15 import qualified Data.Monoid as Monoid
17 import qualified Data.Accessor.MonadState as MonadState
18 import Text.Regex.Posix
22 import qualified ForSyDe.Backend.VHDL.AST as AST
27 import qualified OccName
29 import qualified TyCon
30 import qualified CoreSyn
31 import Outputable ( showSDoc, ppr )
37 import TranslatorTypes
43 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
44 -> [(AST.VHDLId, AST.DesignFile)]
46 createDesignFiles binds =
47 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
48 map (Arrow.second $ AST.DesignFile full_context) units
51 init_session = VHDLSession Map.empty builtin_funcs
52 (units, final_session) =
53 State.runState (createLibraryUnits binds) init_session
54 ty_decls = Map.elems (final_session ^. vsTypes)
56 AST.Library $ mkVHDLBasicId "IEEE",
57 mkUseAll ["IEEE", "std_logic_1164"],
58 mkUseAll ["IEEE", "numeric_std"]
61 mkUseAll ["work", "types"]
63 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
65 -- Create a use foo.bar.all statement. Takes a list of components in the used
66 -- name. Must contain at least two components
67 mkUseAll :: [String] -> AST.ContextItem
69 AST.Use $ from AST.:.: AST.All
71 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
72 from = foldl select base_prefix (tail ss)
73 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
76 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
77 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
79 createLibraryUnits binds = do
80 entities <- Monad.mapM createEntity binds
81 archs <- Monad.mapM createArchitecture binds
84 let AST.EntityDec id _ = ent in
85 (id, [AST.LUEntity ent, AST.LUArch arch])
89 -- | Create an entity for a given function
91 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
92 -> VHDLState AST.EntityDec -- | The resulting entity
94 createEntity (fname, expr) = do
95 -- Strip off lambda's, these will be arguments
96 let (args, letexpr) = CoreSyn.collectBinders expr
97 args' <- Monad.mapM mkMap args
98 -- There must be a let at top level
99 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
101 let ent_decl' = createEntityAST fname args' res'
102 let AST.EntityDec entity_id _ = ent_decl'
103 let signature = Entity entity_id args' res'
104 modA vsSignatures (Map.insert (bndrToString fname) signature)
108 --[(SignalId, SignalInfo)]
110 -> VHDLState VHDLSignalMapElement
111 -- We only need the vsTypes element from the state
112 mkMap = MonadState.lift vsTypes . (\bndr ->
114 --info = Maybe.fromMaybe
115 -- (error $ "Signal not found in the name map? This should not happen!")
116 -- (lookup id sigmap)
117 -- Assume the bndr has a valid VHDL id already
118 id = bndrToVHDLId bndr
119 ty = Var.varType bndr
121 if True -- isPortSigUse $ sigUse info
123 type_mark <- vhdl_ty ty
124 return $ Just (id, type_mark)
129 -- | Create the VHDL AST for an entity
131 CoreSyn.CoreBndr -- | The name of the function
132 -> [VHDLSignalMapElement] -- | The entity's arguments
133 -> VHDLSignalMapElement -- | The entity's result
134 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
136 createEntityAST name args res =
137 AST.EntityDec vhdl_id ports
139 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
140 vhdl_id = mkVHDLBasicId $ bndrToString name
141 ports = Maybe.catMaybes $
142 map (mkIfaceSigDec AST.In) args
143 ++ [mkIfaceSigDec AST.Out res]
145 -- Add a clk port if we have state
146 clk_port = if True -- hasState hsfunc
148 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
152 -- | Create a port declaration
154 AST.Mode -- | The mode for the port (In / Out)
155 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
156 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
158 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
159 mkIfaceSigDec _ Nothing = Nothing
161 -- | Generate a VHDL entity name for the given hsfunc
163 -- TODO: This doesn't work for functions with multiple signatures!
164 -- Use a Basic Id, since using extended id's for entities throws off
165 -- precision and causes problems when generating filenames.
166 mkVHDLBasicId $ hsFuncName hsfunc
168 -- | Create an architecture for a given function
169 createArchitecture ::
170 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
171 -> VHDLState AST.ArchBody -- ^ The architecture for this function
173 createArchitecture (fname, expr) = do
174 --signaturemap <- getA vsSignatures
175 --let signature = Maybe.fromMaybe
176 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
177 -- (Map.lookup hsfunc signaturemap)
178 let entity_id = mkVHDLBasicId $ bndrToString fname
179 -- Strip off lambda's, these will be arguments
180 let (args, letexpr) = CoreSyn.collectBinders expr
181 -- There must be a let at top level
182 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
184 -- Create signal declarations for all internal and state signals
185 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
186 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
188 statements <- Monad.mapM mkConcSm binds
189 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
191 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
192 procs' = map AST.CSPSm procs
193 -- mkSigDec only uses vsTypes from the state
194 mkSigDec' = MonadState.lift vsTypes . mkSigDec
196 -- | Looks up all pairs of old state, new state signals, together with
197 -- the state id they represent.
198 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
199 makeStatePairs flatfunc =
200 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
201 | old_info <- map snd (flat_sigs flatfunc)
202 , new_info <- map snd (flat_sigs flatfunc)
203 -- old_info must be an old state (and, because of the next equality,
204 -- new_info must be a new state).
205 , Maybe.isJust $ oldStateId $ sigUse old_info
206 -- And the state numbers must match
207 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
209 -- Replace the second tuple element with the corresponding SignalInfo
210 --args_states = map (Arrow.second $ signalInfo sigs) args
211 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
212 mkStateProcSm (num, old, new) =
213 AST.ProcSm label [clk] [statement]
215 label = mkVHDLExtId $ "state_" ++ (show num)
216 clk = mkVHDLExtId "clk"
217 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
218 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
219 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
220 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
221 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
223 mkSigDec :: CoreSyn.CoreBndr -> TypeState (Maybe AST.SigDec)
225 if True then do --isInternalSigUse use || isStateSigUse use then do
226 type_mark <- vhdl_ty $ Var.varType bndr
227 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
231 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
233 getSignalId :: SignalInfo -> AST.VHDLId
235 mkVHDLExtId $ Maybe.fromMaybe
236 (error $ "Unnamed signal? This should not happen!")
239 -- | Transforms a core binding into a VHDL concurrent statement
241 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
242 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
244 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
245 signatures <- getA vsSignatures
247 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
248 signature = Maybe.fromMaybe
249 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
250 (Map.lookup (bndrToString f) signatures)
251 entity_id = ent_id signature
252 label = bndrToString bndr
253 -- Add a clk port if we have state
254 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
255 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
256 portmaps = mkAssocElems args bndr signature
258 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
260 -- GHC generates some funny "r = r" bindings in let statements before
261 -- simplification. This outputs some dummy ConcSM for these, so things will at
262 -- least compile for now.
263 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
266 mkConcSm sigs (UncondDef src dst) _ = do
267 src_expr <- vhdl_expr src
268 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
269 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
270 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
271 return $ AST.CSSASm assign
273 vhdl_expr (Left id) = return $ mkIdExpr sigs id
274 vhdl_expr (Right expr) =
277 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
278 (Literal lit Nothing) ->
279 return $ AST.PrimLit lit
280 (Literal lit (Just ty)) -> do
281 -- Create a cast expression, which is just a function call using the
282 -- type name as the function name.
283 let litexpr = AST.PrimLit lit
284 ty_id <- MonadState.lift vsTypes (vhdl_ty ty)
285 let ty_name = AST.NSimple ty_id
286 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
287 return $ AST.PrimFCall $ AST.FCall ty_name args
289 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
291 mkConcSm sigs (CondDef cond true false dst) _ =
293 cond_expr = mkIdExpr sigs cond
294 true_expr = mkIdExpr sigs true
295 false_expr = mkIdExpr sigs false
296 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
297 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
298 whenelse = AST.WhenElse true_wform cond_expr
299 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
300 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
302 return $ AST.CSSASm assign
304 -- | Turn a SignalId into a VHDL Expr
305 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
307 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
308 AST.PrimName src_name
311 [CoreSyn.CoreExpr] -- | The argument that are applied to function
312 -> CoreSyn.CoreBndr -- | The binder in which to store the result
313 -> Entity -- | The entity to map against.
314 -> [AST.AssocElem] -- | The resulting port maps
316 mkAssocElems args res entity =
317 -- Create the actual AssocElems
318 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
320 -- Turn the ports and signals from a map into a flat list. This works,
321 -- since the maps must have an identical form by definition. TODO: Check
323 arg_ports = ent_args entity
324 res_port = ent_res entity
325 -- Extract the id part from the (id, type) tuple
326 ports = map (Monad.liftM fst) (res_port : arg_ports)
327 -- Translate signal numbers into names
328 sigs = (bndrToString res : map (bndrToString.varBndr) args)
330 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
331 -- simple Var CoreExprs, not complexer ones.
332 varBndr :: CoreSyn.CoreExpr -> Var.Id
333 varBndr (CoreSyn.Var id) = id
335 -- | Look up a signal in the signal name map
336 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
337 lookupSigName sigs sig = name
339 info = Maybe.fromMaybe
340 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
342 name = Maybe.fromMaybe
343 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
346 -- | Create an VHDL port -> signal association
347 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
348 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
349 mkAssocElem Nothing _ = Nothing
351 -- | The VHDL Bit type
352 bit_ty :: AST.TypeMark
353 bit_ty = AST.unsafeVHDLBasicId "Bit"
355 -- | The VHDL Boolean type
356 bool_ty :: AST.TypeMark
357 bool_ty = AST.unsafeVHDLBasicId "Boolean"
359 -- | The VHDL std_logic
360 std_logic_ty :: AST.TypeMark
361 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
363 -- Translate a Haskell type to a VHDL type
364 vhdl_ty :: Type.Type -> TypeState AST.TypeMark
367 let builtin_ty = do -- See if this is a tycon and lookup its name
368 (tycon, args) <- Type.splitTyConApp_maybe ty
369 let name = Name.getOccString (TyCon.tyConName tycon)
370 Map.lookup name builtin_types
371 -- If not a builtin type, try the custom types
372 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
373 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
374 -- Found a type, return it
376 -- No type yet, try to construct it
379 -- Use the Maybe Monad for failing when one of these fails
380 (tycon, args) <- Type.splitTyConApp_maybe ty
381 let name = Name.getOccString (TyCon.tyConName tycon)
383 "FSVec" -> Just $ mk_vector_ty (fsvec_len ty) ty
384 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
386 -- Return new_ty when a new type was successfully created
388 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
391 -- | Create a VHDL vector type
393 Int -- ^ The length of the vector
394 -> Type.Type -- ^ The Haskell type to create a VHDL type for
395 -> TypeState AST.TypeMark -- The typemark created.
397 mk_vector_ty len ty = do
398 -- Assume there is a single type argument
399 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
401 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
402 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
403 let ty_dec = AST.TypeDec ty_id ty_def
404 -- TODO: Check name uniqueness
405 State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
411 ("Bit", std_logic_ty),
412 ("Bool", bool_ty) -- TysWiredIn.boolTy
416 -- Can only contain alphanumerics and underscores. The supplied string must be
417 -- a valid basic id, otherwise an error value is returned. This function is
418 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
420 mkVHDLBasicId :: String -> AST.VHDLId
422 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
424 -- Strip invalid characters.
425 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
426 -- Strip leading numbers and underscores
427 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
428 -- Strip multiple adjacent underscores
429 strip_multiscore = concat . map (\cs ->
435 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
436 -- different characters than basic ids, but can never be used to refer to
438 -- Use extended Ids for any values that are taken from the source file.
439 mkVHDLExtId :: String -> AST.VHDLId
441 AST.unsafeVHDLExtId $ strip_invalid s
443 -- Allowed characters, taken from ForSyde's mkVHDLExtId
444 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
445 strip_invalid = filter (`elem` allowed)
447 -- Creates a VHDL Id from a binder
452 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
454 -- Extracts the binder name as a String
459 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
461 -- | A consise representation of a (set of) ports on a builtin function
462 --type PortMap = HsValueMap (String, AST.TypeMark)
463 -- | A consise representation of a builtin function
464 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
466 -- | Translate a list of concise representation of builtin functions to a
468 mkBuiltins :: [BuiltIn] -> SignatureMap
469 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
471 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
474 builtin_hsfuncs = Map.keys builtin_funcs
475 builtin_funcs = mkBuiltins
477 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
478 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
479 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
480 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
483 -- | Map a port specification of a builtin function to a VHDL Signal to put in
485 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
486 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)