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 import GlobalNameTable
46 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
47 -> [(AST.VHDLId, AST.DesignFile)]
49 createDesignFiles binds =
50 (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package]) :
51 map (Arrow.second $ AST.DesignFile full_context) units
54 init_session = VHDLSession Map.empty Map.empty builtin_funcs globalNameTable
55 (units, final_session) =
56 State.runState (createLibraryUnits binds) init_session
57 ty_decls = Map.elems (final_session ^. vsTypes)
59 AST.Library $ mkVHDLBasicId "IEEE",
60 mkUseAll ["IEEE", "std_logic_1164"],
61 mkUseAll ["IEEE", "numeric_std"]
64 mkUseAll ["work", "types"]
66 type_package = AST.LUPackageDec $ AST.PackageDec (mkVHDLBasicId "types") (map (AST.PDITD . snd) ty_decls)
68 -- Create a use foo.bar.all statement. Takes a list of components in the used
69 -- name. Must contain at least two components
70 mkUseAll :: [String] -> AST.ContextItem
72 AST.Use $ from AST.:.: AST.All
74 base_prefix = (AST.NSimple $ mkVHDLBasicId $ head ss)
75 from = foldl select base_prefix (tail ss)
76 select prefix s = AST.NSelected $ prefix AST.:.: (AST.SSimple $ mkVHDLBasicId s)
79 [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
80 -> VHDLState [(AST.VHDLId, [AST.LibraryUnit])]
82 createLibraryUnits binds = do
83 entities <- Monad.mapM createEntity binds
84 archs <- Monad.mapM createArchitecture binds
87 let AST.EntityDec id _ = ent in
88 (id, [AST.LUEntity ent, AST.LUArch arch])
92 -- | Create an entity for a given function
94 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- | The function
95 -> VHDLState AST.EntityDec -- | The resulting entity
97 createEntity (fname, expr) = do
98 -- Strip off lambda's, these will be arguments
99 let (args, letexpr) = CoreSyn.collectBinders expr
100 args' <- Monad.mapM mkMap args
101 -- There must be a let at top level
102 let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
104 let ent_decl' = createEntityAST fname args' res'
105 let AST.EntityDec entity_id _ = ent_decl'
106 let signature = Entity entity_id args' res'
107 modA vsSignatures (Map.insert (bndrToString fname) signature)
111 --[(SignalId, SignalInfo)]
113 -> VHDLState VHDLSignalMapElement
114 -- We only need the vsTypes element from the state
117 --info = Maybe.fromMaybe
118 -- (error $ "Signal not found in the name map? This should not happen!")
119 -- (lookup id sigmap)
120 -- Assume the bndr has a valid VHDL id already
121 id = bndrToVHDLId bndr
122 ty = Var.varType bndr
124 if True -- isPortSigUse $ sigUse info
126 type_mark <- vhdl_ty ty
127 return $ Just (id, type_mark)
132 -- | Create the VHDL AST for an entity
134 CoreSyn.CoreBndr -- | The name of the function
135 -> [VHDLSignalMapElement] -- | The entity's arguments
136 -> VHDLSignalMapElement -- | The entity's result
137 -> AST.EntityDec -- | The entity with the ent_decl filled in as well
139 createEntityAST name args res =
140 AST.EntityDec vhdl_id ports
142 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
143 vhdl_id = mkVHDLBasicId $ bndrToString name
144 ports = Maybe.catMaybes $
145 map (mkIfaceSigDec AST.In) args
146 ++ [mkIfaceSigDec AST.Out res]
148 -- Add a clk port if we have state
149 clk_port = if True -- hasState hsfunc
151 Just $ AST.IfaceSigDec (mkVHDLExtId "clk") AST.In VHDL.std_logic_ty
155 -- | Create a port declaration
157 AST.Mode -- | The mode for the port (In / Out)
158 -> Maybe (AST.VHDLId, AST.TypeMark) -- | The id and type for the port
159 -> Maybe AST.IfaceSigDec -- | The resulting port declaration
161 mkIfaceSigDec mode (Just (id, ty)) = Just $ AST.IfaceSigDec id mode ty
162 mkIfaceSigDec _ Nothing = Nothing
164 -- | Generate a VHDL entity name for the given hsfunc
166 -- TODO: This doesn't work for functions with multiple signatures!
167 -- Use a Basic Id, since using extended id's for entities throws off
168 -- precision and causes problems when generating filenames.
169 mkVHDLBasicId $ hsFuncName hsfunc
171 -- | Create an architecture for a given function
172 createArchitecture ::
173 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The function
174 -> VHDLState AST.ArchBody -- ^ The architecture for this function
176 createArchitecture (fname, expr) = do
177 --signaturemap <- getA vsSignatures
178 --let signature = Maybe.fromMaybe
179 -- (error $ "Generating architecture for function " ++ (prettyShow hsfunc) ++ "without signature? This should not happen!")
180 -- (Map.lookup hsfunc signaturemap)
181 let entity_id = mkVHDLBasicId $ bndrToString fname
182 -- Strip off lambda's, these will be arguments
183 let (args, letexpr) = CoreSyn.collectBinders expr
184 -- There must be a let at top level
185 let (CoreSyn.Let (CoreSyn.Rec binds) res) = letexpr
187 -- Create signal declarations for all internal and state signals
188 sig_dec_maybes <- mapM (mkSigDec' . fst) binds
189 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
191 statements <- Monad.mapM mkConcSm binds
192 return $ AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
194 procs = map mkStateProcSm [] -- (makeStatePairs flatfunc)
195 procs' = map AST.CSPSm procs
196 -- mkSigDec only uses vsTypes from the state
199 -- | Looks up all pairs of old state, new state signals, together with
200 -- the state id they represent.
201 makeStatePairs :: FlatFunction -> [(StateId, SignalInfo, SignalInfo)]
202 makeStatePairs flatfunc =
203 [(Maybe.fromJust $ oldStateId $ sigUse old_info, old_info, new_info)
204 | old_info <- map snd (flat_sigs flatfunc)
205 , new_info <- map snd (flat_sigs flatfunc)
206 -- old_info must be an old state (and, because of the next equality,
207 -- new_info must be a new state).
208 , Maybe.isJust $ oldStateId $ sigUse old_info
209 -- And the state numbers must match
210 , (oldStateId $ sigUse old_info) == (newStateId $ sigUse new_info)]
212 -- Replace the second tuple element with the corresponding SignalInfo
213 --args_states = map (Arrow.second $ signalInfo sigs) args
214 mkStateProcSm :: (StateId, SignalInfo, SignalInfo) -> AST.ProcSm
215 mkStateProcSm (num, old, new) =
216 AST.ProcSm label [clk] [statement]
218 label = mkVHDLExtId $ "state_" ++ (show num)
219 clk = mkVHDLExtId "clk"
220 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
221 wform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple $ getSignalId new) Nothing]
222 assign = AST.SigAssign (AST.NSimple $ getSignalId old) wform
223 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
224 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
226 mkSigDec :: CoreSyn.CoreBndr -> VHDLState (Maybe AST.SigDec)
228 if True then do --isInternalSigUse use || isStateSigUse use then do
229 type_mark <- vhdl_ty $ Var.varType bndr
230 return $ Just (AST.SigDec (bndrToVHDLId bndr) type_mark Nothing)
234 -- | Creates a VHDL Id from a named SignalInfo. Errors out if the SignalInfo
236 getSignalId :: SignalInfo -> AST.VHDLId
238 mkVHDLExtId $ Maybe.fromMaybe
239 (error $ "Unnamed signal? This should not happen!")
242 -- | Transforms a core binding into a VHDL concurrent statement
244 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
245 -> VHDLState AST.ConcSm -- ^ The corresponding VHDL component instantiation.
247 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
248 signatures <- getA vsSignatures
250 (CoreSyn.Var f, args) = CoreSyn.collectArgs app
251 signature = Maybe.fromMaybe
252 (error $ "Using function '" ++ (bndrToString f) ++ "' without signature? This should not happen!")
253 (Map.lookup (bndrToString f) signatures)
254 entity_id = ent_id signature
255 label = bndrToString bndr
256 -- Add a clk port if we have state
257 --clk_port = Maybe.fromJust $ mkAssocElem (Just $ mkVHDLExtId "clk") "clk"
258 --portmaps = mkAssocElems sigs args res signature ++ (if hasState hsfunc then [clk_port] else [])
259 portmaps = mkAssocElems args bndr signature
261 return $ AST.CSISm $ AST.CompInsSm (mkVHDLExtId label) (AST.IUEntity (AST.NSimple entity_id)) (AST.PMapAspect portmaps)
263 -- GHC generates some funny "r = r" bindings in let statements before
264 -- simplification. This outputs some dummy ConcSM for these, so things will at
265 -- least compile for now.
266 mkConcSm (bndr, CoreSyn.Var _) = return $ AST.CSPSm $ AST.ProcSm (mkVHDLBasicId "unused") [] []
269 mkConcSm sigs (UncondDef src dst) _ = do
270 src_expr <- vhdl_expr src
271 let src_wform = AST.Wform [AST.WformElem src_expr Nothing]
272 let dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
273 let assign = dst_name AST.:<==: (AST.ConWforms [] src_wform Nothing)
274 return $ AST.CSSASm assign
276 vhdl_expr (Left id) = return $ mkIdExpr sigs id
277 vhdl_expr (Right expr) =
280 return $ (mkIdExpr sigs id) AST.:=: (AST.PrimLit lit)
281 (Literal lit Nothing) ->
282 return $ AST.PrimLit lit
283 (Literal lit (Just ty)) -> do
284 -- Create a cast expression, which is just a function call using the
285 -- type name as the function name.
286 let litexpr = AST.PrimLit lit
288 let ty_name = AST.NSimple ty_id
289 let args = [Nothing AST.:=>: (AST.ADExpr litexpr)]
290 return $ AST.PrimFCall $ AST.FCall ty_name args
292 return $ (mkIdExpr sigs a) AST.:=: (mkIdExpr sigs b)
294 mkConcSm sigs (CondDef cond true false dst) _ =
296 cond_expr = mkIdExpr sigs cond
297 true_expr = mkIdExpr sigs true
298 false_expr = mkIdExpr sigs false
299 false_wform = AST.Wform [AST.WformElem false_expr Nothing]
300 true_wform = AST.Wform [AST.WformElem true_expr Nothing]
301 whenelse = AST.WhenElse true_wform cond_expr
302 dst_name = AST.NSimple (getSignalId $ signalInfo sigs dst)
303 assign = dst_name AST.:<==: (AST.ConWforms [whenelse] false_wform Nothing)
305 return $ AST.CSSASm assign
307 -- | Turn a SignalId into a VHDL Expr
308 mkIdExpr :: [(SignalId, SignalInfo)] -> SignalId -> AST.Expr
310 let src_name = AST.NSimple (getSignalId $ signalInfo sigs id) in
311 AST.PrimName src_name
314 [CoreSyn.CoreExpr] -- | The argument that are applied to function
315 -> CoreSyn.CoreBndr -- | The binder in which to store the result
316 -> Entity -- | The entity to map against.
317 -> [AST.AssocElem] -- | The resulting port maps
319 mkAssocElems args res entity =
320 -- Create the actual AssocElems
321 Maybe.catMaybes $ zipWith mkAssocElem ports sigs
323 -- Turn the ports and signals from a map into a flat list. This works,
324 -- since the maps must have an identical form by definition. TODO: Check
326 arg_ports = ent_args entity
327 res_port = ent_res entity
328 -- Extract the id part from the (id, type) tuple
329 ports = map (Monad.liftM fst) (res_port : arg_ports)
330 -- Translate signal numbers into names
331 sigs = (bndrToString res : map (bndrToString.varBndr) args)
333 -- Turns a Var CoreExpr into the Id inside it. Will of course only work for
334 -- simple Var CoreExprs, not complexer ones.
335 varBndr :: CoreSyn.CoreExpr -> Var.Id
336 varBndr (CoreSyn.Var id) = id
338 -- | Look up a signal in the signal name map
339 lookupSigName :: [(SignalId, SignalInfo)] -> SignalId -> String
340 lookupSigName sigs sig = name
342 info = Maybe.fromMaybe
343 (error $ "Unknown signal " ++ (show sig) ++ " used? This should not happen!")
345 name = Maybe.fromMaybe
346 (error $ "Unnamed signal " ++ (show sig) ++ " used? This should not happen!")
349 -- | Create an VHDL port -> signal association
350 mkAssocElem :: Maybe AST.VHDLId -> String -> Maybe AST.AssocElem
351 mkAssocElem (Just port) signal = Just $ Just port AST.:=>: (AST.ADName (AST.NSimple (mkVHDLExtId signal)))
352 mkAssocElem Nothing _ = Nothing
354 -- | The VHDL Bit type
355 bit_ty :: AST.TypeMark
356 bit_ty = AST.unsafeVHDLBasicId "Bit"
358 -- | The VHDL Boolean type
359 bool_ty :: AST.TypeMark
360 bool_ty = AST.unsafeVHDLBasicId "Boolean"
362 -- | The VHDL std_logic
363 std_logic_ty :: AST.TypeMark
364 std_logic_ty = AST.unsafeVHDLBasicId "std_logic"
366 -- Translate a Haskell type to a VHDL type
367 vhdl_ty :: Type.Type -> VHDLState AST.TypeMark
369 typemap <- getA vsTypes
370 let builtin_ty = do -- See if this is a tycon and lookup its name
371 (tycon, args) <- Type.splitTyConApp_maybe ty
372 let name = Name.getOccString (TyCon.tyConName tycon)
373 Map.lookup name builtin_types
374 -- If not a builtin type, try the custom types
375 let existing_ty = (fmap fst) $ Map.lookup (OrdType ty) typemap
376 case Monoid.getFirst $ Monoid.mconcat (map Monoid.First [builtin_ty, existing_ty]) of
377 -- Found a type, return it
379 -- No type yet, try to construct it
382 -- Use the Maybe Monad for failing when one of these fails
383 (tycon, args) <- Type.splitTyConApp_maybe ty
384 let name = Name.getOccString (TyCon.tyConName tycon)
386 "TFVec" -> Just $ mk_vector_ty (tfvec_len ty) ty
387 "SizedWord" -> Just $ mk_vector_ty (sized_word_len ty) ty
389 -- Return new_ty when a new type was successfully created
391 (error $ "Unsupported Haskell type: " ++ (showSDoc $ ppr ty))
394 -- | Create a VHDL vector type
396 Int -- ^ The length of the vector
397 -> Type.Type -- ^ The Haskell type to create a VHDL type for
398 -> VHDLState AST.TypeMark -- The typemark created.
400 mk_vector_ty len ty = do
401 -- Assume there is a single type argument
402 let ty_id = mkVHDLExtId $ "vector_" ++ (show len)
404 let range = AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len - 1))]
405 let ty_def = AST.TDA $ AST.ConsArrayDef range std_logic_ty
406 let ty_dec = AST.TypeDec ty_id ty_def
407 -- TODO: Check name uniqueness
408 --State.modify (Map.insert (OrdType ty) (ty_id, ty_dec))
409 modA vsTypes (Map.insert (OrdType ty) (ty_id, ty_dec))
410 modA vsTypeFuns (Map.insert (OrdType ty) (genUnconsVectorFuns std_logic_ty ty_id))
416 ("Bit", std_logic_ty),
417 ("Bool", bool_ty) -- TysWiredIn.boolTy
421 -- Can only contain alphanumerics and underscores. The supplied string must be
422 -- a valid basic id, otherwise an error value is returned. This function is
423 -- not meant to be passed identifiers from a source file, use mkVHDLExtId for
425 mkVHDLBasicId :: String -> AST.VHDLId
427 AST.unsafeVHDLBasicId $ (strip_multiscore . strip_leading . strip_invalid) s
429 -- Strip invalid characters.
430 strip_invalid = filter (`elem` ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ "_.")
431 -- Strip leading numbers and underscores
432 strip_leading = dropWhile (`elem` ['0'..'9'] ++ "_")
433 -- Strip multiple adjacent underscores
434 strip_multiscore = concat . map (\cs ->
440 -- Shortcut for Extended VHDL Id's. These Id's can contain a lot more
441 -- different characters than basic ids, but can never be used to refer to
443 -- Use extended Ids for any values that are taken from the source file.
444 mkVHDLExtId :: String -> AST.VHDLId
446 AST.unsafeVHDLExtId $ strip_invalid s
448 -- Allowed characters, taken from ForSyde's mkVHDLExtId
449 allowed = ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9'] ++ " \"#&\\'()*+,./:;<=>_|!$%@?[]^`{}~-"
450 strip_invalid = filter (`elem` allowed)
452 -- Creates a VHDL Id from a binder
457 bndrToVHDLId = mkVHDLExtId . OccName.occNameString . Name.nameOccName . Var.varName
459 -- Extracts the binder name as a String
464 bndrToString = OccName.occNameString . Name.nameOccName . Var.varName
466 -- | A consise representation of a (set of) ports on a builtin function
467 --type PortMap = HsValueMap (String, AST.TypeMark)
468 -- | A consise representation of a builtin function
469 data BuiltIn = BuiltIn String [(String, AST.TypeMark)] (String, AST.TypeMark)
471 -- | Translate a list of concise representation of builtin functions to a
473 mkBuiltins :: [BuiltIn] -> SignatureMap
474 mkBuiltins = Map.fromList . map (\(BuiltIn name args res) ->
476 Entity (VHDL.mkVHDLBasicId name) (map toVHDLSignalMapElement args) (toVHDLSignalMapElement res))
479 builtin_hsfuncs = Map.keys builtin_funcs
480 builtin_funcs = mkBuiltins
482 BuiltIn "hwxor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
483 BuiltIn "hwand" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
484 BuiltIn "hwor" [("a", VHDL.bit_ty), ("b", VHDL.bit_ty)] ("o", VHDL.bit_ty),
485 BuiltIn "hwnot" [("a", VHDL.bit_ty)] ("o", VHDL.bit_ty)
488 -- | Map a port specification of a builtin function to a VHDL Signal to put in
490 toVHDLSignalMapElement :: (String, AST.TypeMark) -> VHDLSignalMapElement
491 toVHDLSignalMapElement (name, ty) = Just (mkVHDLBasicId name, ty)