1 module CLasH.VHDL.Generate where
4 import qualified Data.List as List
5 import qualified Data.Map as Map
6 import qualified Control.Monad as Monad
8 import qualified Data.Either as Either
10 import Data.Accessor.MonadState as MonadState
14 import qualified Language.VHDL.AST as AST
17 import qualified CoreSyn
21 import qualified IdInfo
22 import qualified Literal
24 import qualified TyCon
27 import CLasH.Translator.TranslatorTypes
28 import CLasH.VHDL.Constants
29 import CLasH.VHDL.VHDLTypes
30 import CLasH.VHDL.VHDLTools
31 import CLasH.Utils as Utils
32 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.Pretty
34 import qualified CLasH.Normalize as Normalize
36 -----------------------------------------------------------------------------
37 -- Functions to generate VHDL for user-defined functions.
38 -----------------------------------------------------------------------------
40 -- | Create an entity for a given function
43 -> TranslatorSession Entity -- ^ The resulting entity
45 getEntity fname = Utils.makeCached fname tsEntities $ do
46 expr <- Normalize.getNormalized fname
47 -- Split the normalized expression
48 let (args, binds, res) = Normalize.splitNormalized expr
49 -- Generate ports for all non-empty types
50 args' <- catMaybesM $ mapM mkMap args
51 -- TODO: Handle Nothing
53 count <- getA tsEntityCounter
54 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
55 putA tsEntityCounter (count + 1)
56 let ent_decl = createEntityAST vhdl_id args' res'
57 let signature = Entity vhdl_id args' res' ent_decl
61 --[(SignalId, SignalInfo)]
63 -> TranslatorSession (Maybe Port)
66 --info = Maybe.fromMaybe
67 -- (error $ "Signal not found in the name map? This should not happen!")
69 -- Assume the bndr has a valid VHDL id already
72 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
74 type_mark_maybe <- MonadState.lift tsType $ vhdl_ty error_msg ty
75 case type_mark_maybe of
76 Just type_mark -> return $ Just (id, type_mark)
77 Nothing -> return Nothing
80 -- | Create the VHDL AST for an entity
82 AST.VHDLId -- ^ The name of the function
83 -> [Port] -- ^ The entity's arguments
84 -> Maybe Port -- ^ The entity's result
85 -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
87 createEntityAST vhdl_id args res =
88 AST.EntityDec vhdl_id ports
90 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
91 ports = map (mkIfaceSigDec AST.In) args
92 ++ (Maybe.maybeToList res_port)
93 ++ [clk_port,resetn_port]
94 -- Add a clk port if we have state
95 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
96 resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
97 res_port = fmap (mkIfaceSigDec AST.Out) res
99 -- | Create a port declaration
101 AST.Mode -- ^ The mode for the port (In / Out)
102 -> Port -- ^ The id and type for the port
103 -> AST.IfaceSigDec -- ^ The resulting port declaration
105 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
107 -- | Create an architecture for a given function
109 CoreSyn.CoreBndr -- ^ The function to get an architecture for
110 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
111 -- ^ The architecture for this function
113 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
114 expr <- Normalize.getNormalized fname
115 -- Split the normalized expression
116 let (args, binds, res) = Normalize.splitNormalized expr
118 -- Get the entity for this function
119 signature <- getEntity fname
120 let entity_id = ent_id signature
122 -- Create signal declarations for all binders in the let expression, except
123 -- for the output port (that will already have an output port declared in
125 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
126 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
127 -- Process each bind, resulting in info about state variables and concurrent
129 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
130 let (in_state_maybes, out_state_maybes) = unzip state_vars
131 let (statementss, used_entitiess) = unzip sms
132 -- Create a state proc, if needed
133 state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
134 ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
135 ([], []) -> return []
136 (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
137 -- Join the create statements and the (optional) state_proc
138 let statements = concat statementss ++ state_proc
139 -- Create the architecture
140 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
141 let used_entities = concat used_entitiess
142 return (arch, used_entities)
144 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
145 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
146 -- ^ ((Input state variable, output state variable), (statements, used entities))
147 -- newtype unpacking is just a cast
148 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
149 | hasStateType packed && not (hasStateType unpacked)
150 = return ((Just bndr, Nothing), ([], []))
151 -- With simplCore, newtype packing is just a cast
152 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
153 | hasStateType packed && not (hasStateType unpacked)
154 = return ((Nothing, Just state), ([], []))
155 -- Without simplCore, newtype packing uses a data constructor
156 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
158 = return ((Nothing, Just state), ([], []))
159 -- Anything else is handled by mkConcSm
162 return ((Nothing, Nothing), sms)
165 (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
166 -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
167 mkStateProcSm (old, new) = do
168 nonempty <- hasNonEmptyType old
170 then return [AST.CSPSm $ AST.ProcSm label [clockId,resetId] [statement]]
173 label = mkVHDLBasicId $ "state"
174 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
175 wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
176 clk_assign = AST.SigAssign (varToVHDLName old) wform
177 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
178 resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
180 clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
181 statement = AST.IfSm resetn_is_low reset_statement clk_statement Nothing
184 -- | Transforms a core binding into a VHDL concurrent statement
186 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
187 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
188 -- ^ The corresponding VHDL concurrent statements and entities
192 -- Ignore Cast expressions, they should not longer have any meaning as long as
193 -- the type works out. Throw away state repacking
194 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
195 | hasStateType to && hasStateType from
197 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
199 -- Simple a = b assignments are just like applications, but without arguments.
200 -- We can't just generate an unconditional assignment here, since b might be a
201 -- top level binding (e.g., a function with no arguments).
202 mkConcSm (bndr, CoreSyn.Var v) = do
203 genApplication (Left bndr) v []
205 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
206 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
207 let valargs = get_val_args (Var.varType f) args
208 genApplication (Left bndr) f (map Left valargs)
210 -- A single alt case must be a selector. This means thee scrutinee is a simple
211 -- variable, the alternative is a dataalt with a single non-wild binder that
213 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
214 -- Don't generate VHDL for substate extraction
215 | hasStateType bndr = return ([], [])
218 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
219 bndrs' <- Monad.filterM hasNonEmptyType bndrs
220 case List.elemIndex sel_bndr bndrs' of
222 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
223 let label = labels!!i
224 let sel_name = mkSelectedName (varToVHDLName scrut) label
225 let sel_expr = AST.PrimName sel_name
226 return ([mkUncondAssign (Left bndr) sel_expr], [])
227 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
229 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
231 -- Multiple case alt are be conditional assignments and have only wild
232 -- binders in the alts and only variables in the case values and a variable
233 -- for a scrutinee. We check the constructor of the second alt, since the
234 -- first is the default case, if there is any.
235 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
236 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
237 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
238 true_expr <- MonadState.lift tsType $ varToVHDLExpr true
239 false_expr <- MonadState.lift tsType $ varToVHDLExpr false
240 return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
242 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
243 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
244 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
246 -----------------------------------------------------------------------------
247 -- Functions to generate VHDL for builtin functions
248 -----------------------------------------------------------------------------
250 -- | A function to wrap a builder-like function that expects its arguments to
252 genExprArgs wrap dst func args = do
253 args' <- argsToVHDLExprs args
256 -- | Turn the all lefts into VHDL Expressions.
257 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
258 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
260 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
261 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
262 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
263 ty_maybe <- vhdl_ty errmsg expr
266 vhdl_expr <- varToVHDLExpr $ exprToVar expr
267 return $ Just vhdl_expr
268 Nothing -> return $ Nothing
270 argToVHDLExpr (Right expr) = return $ Just expr
272 -- A function to wrap a builder-like function that generates no component
275 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
276 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
277 genNoInsts wrap dst func args = do
278 concsms <- wrap dst func args
281 -- | A function to wrap a builder-like function that expects its arguments to
284 (dst -> func -> [Var.Var] -> res)
285 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
286 genVarArgs wrap dst func args = wrap dst func args'
288 args' = map exprToVar exprargs
289 -- Check (rather crudely) that all arguments are CoreExprs
290 (exprargs, []) = Either.partitionEithers args
292 -- | A function to wrap a builder-like function that expects its arguments to
295 (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
296 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
297 genLitArgs wrap dst func args = do
298 hscenv <- MonadState.lift tsType $ getA tsHscEnv
299 let (exprargs, []) = Either.partitionEithers args
300 -- FIXME: Check if we were passed an CoreSyn.App
301 let litargs = concat (map (getLiterals hscenv) exprargs)
302 let args' = map exprToLit litargs
303 concsms <- wrap dst func args'
306 -- | A function to wrap a builder-like function that produces an expression
307 -- and expects it to be assigned to the destination.
309 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
310 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
311 genExprRes wrap dst func args = do
312 expr <- wrap dst func args
313 return $ [mkUncondAssign dst expr]
315 -- | Generate a binary operator application. The first argument should be a
316 -- constructor from the AST.Expr type, e.g. AST.And.
317 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
318 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
319 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
320 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
322 -- | Generate a unary operator application
323 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
324 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
325 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
326 genOperator1' op _ f [arg] = return $ op arg
328 -- | Generate a unary operator application
329 genNegation :: BuiltinBuilder
330 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
331 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
332 genNegation' _ f [arg] = do
333 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
334 let ty = Var.varType arg
335 let (tycon, args) = Type.splitTyConApp ty
336 let name = Name.getOccString (TyCon.tyConName tycon)
338 "SizedInt" -> return $ AST.Neg arg1
339 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
341 -- | Generate a function call from the destination binder, function name and a
342 -- list of expressions (its arguments)
343 genFCall :: Bool -> BuiltinBuilder
344 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
345 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
346 genFCall' switch (Left res) f args = do
347 let fname = varToString f
348 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
349 id <- MonadState.lift tsType $ vectorFunId el_ty fname
350 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
351 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
352 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
354 genFromSizedWord :: BuiltinBuilder
355 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
356 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
357 genFromSizedWord' (Left res) f args@[arg] = do
358 return $ [mkUncondAssign (Left res) arg]
359 -- let fname = varToString f
360 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
361 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
362 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
364 genResize :: BuiltinBuilder
365 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
366 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
367 genResize' (Left res) f [arg] = do {
368 ; let { ty = Var.varType res
369 ; (tycon, args) = Type.splitTyConApp ty
370 ; name = Name.getOccString (TyCon.tyConName tycon)
372 ; len <- case name of
373 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
374 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
375 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
376 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
378 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
380 -- FIXME: I'm calling genLitArgs which is very specific function,
381 -- which needs to be fixed as well
382 genFromInteger :: BuiltinBuilder
383 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
384 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
385 genFromInteger' (Left res) f lits = do {
386 ; let { ty = Var.varType res
387 ; (tycon, args) = Type.splitTyConApp ty
388 ; name = Name.getOccString (TyCon.tyConName tycon)
390 ; len <- case name of
391 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
392 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
394 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
395 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
397 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
398 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
399 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
403 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
405 genSizedInt :: BuiltinBuilder
406 genSizedInt = genFromInteger
409 -- | Generate a Builder for the builtin datacon TFVec
410 genTFVec :: BuiltinBuilder
411 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
412 -- Generate Assignments for all the binders
413 ; letAssigns <- mapM genBinderAssign letBinders
414 -- Generate assignments for the result (which might be another let binding)
415 ; (resBinders,resAssignments) <- genResAssign letRes
416 -- Get all the Assigned binders
417 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
418 -- Make signal names for all the assigned binders
419 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
420 -- Assign all the signals to the resulting vector
421 ; let { vecsigns = mkAggregateSignal sigs
422 ; vecassign = mkUncondAssign (Left res) vecsigns
424 -- Generate all the signal declaration for the assigned binders
425 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
426 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
427 -- Setup the VHDL Block
428 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
429 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
431 -- Return the block statement coressponding to the TFVec literal
432 ; return $ [AST.CSBSm block]
435 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
436 -- For now we only translate applications
437 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
438 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
439 let valargs = get_val_args (Var.varType f) args
440 apps <- genApplication (Left bndr) f (map Left valargs)
441 return (Just bndr, apps)
442 genBinderAssign _ = return (Nothing,[])
443 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
444 genResAssign app@(CoreSyn.App _ letexpr) = do
446 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
447 letapps <- mapM genBinderAssign letbndrs
448 let bndrs = Maybe.catMaybes (map fst letapps)
449 let app = (map snd letapps)
450 (vars, apps) <- genResAssign letres
451 return ((bndrs ++ vars),((concat app) ++ apps))
452 otherwise -> return ([],[])
453 genResAssign _ = return ([],[])
455 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
456 ; let { elems = reduceCoreListToHsList app
457 -- Make signal names for all the binders
458 ; binders = map (\expr -> case expr of
460 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
461 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
463 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
464 -- Assign all the signals to the resulting vector
465 ; let { vecsigns = mkAggregateSignal sigs
466 ; vecassign = mkUncondAssign (Left res) vecsigns
467 -- Setup the VHDL Block
468 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
469 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
471 -- Return the block statement coressponding to the TFVec literal
472 ; return $ [AST.CSBSm block]
475 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
477 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
479 -- | Generate a generate statement for the builtin function "map"
480 genMap :: BuiltinBuilder
481 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
482 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
483 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
484 -- we must index it (which we couldn't if it was a VHDL Expr, since only
485 -- VHDLNames can be indexed).
486 -- Setup the generate scheme
487 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
488 -- TODO: Use something better than varToString
489 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
490 ; n_id = mkVHDLBasicId "n"
491 ; n_expr = idToVHDLExpr n_id
492 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
493 ; genScheme = AST.ForGn n_id range
494 -- Create the content of the generate statement: Applying the mapped_f to
495 -- each of the elements in arg, storing to each element in res
496 ; resname = mkIndexedName (varToVHDLName res) n_expr
497 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
498 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
499 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
501 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
502 -- Return the generate statement
503 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
506 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
508 genZipWith :: BuiltinBuilder
509 genZipWith = genVarArgs genZipWith'
510 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
511 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
512 -- Setup the generate scheme
513 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
514 -- TODO: Use something better than varToString
515 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
516 ; n_id = mkVHDLBasicId "n"
517 ; n_expr = idToVHDLExpr n_id
518 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
519 ; genScheme = AST.ForGn n_id range
520 -- Create the content of the generate statement: Applying the zipped_f to
521 -- each of the elements in arg1 and arg2, storing to each element in res
522 ; resname = mkIndexedName (varToVHDLName res) n_expr
523 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
524 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
526 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
527 -- Return the generate functions
528 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
531 genFoldl :: BuiltinBuilder
532 genFoldl = genFold True
534 genFoldr :: BuiltinBuilder
535 genFoldr = genFold False
537 genFold :: Bool -> BuiltinBuilder
538 genFold left = genVarArgs (genFold' left)
540 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
541 genFold' left res f args@[folded_f , start ,vec]= do
542 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
543 genFold'' len left res f args
545 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
546 -- Special case for an empty input vector, just assign start to res
547 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
548 arg <- MonadState.lift tsType $ varToVHDLExpr start
549 return ([mkUncondAssign (Left res) arg], [])
551 genFold'' len left (Left res) f [folded_f, start, vec] = do
553 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
554 -- An expression for len-1
555 let len_min_expr = (AST.PrimLit $ show (len-1))
556 -- evec is (TFVec n), so it still needs an element type
557 let (nvec, _) = Type.splitAppTy (Var.varType vec)
558 -- Put the type of the start value in nvec, this will be the type of our
560 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
561 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
562 -- TODO: Handle Nothing
563 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
564 -- Setup the generate scheme
565 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
566 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
567 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
568 else AST.DownRange len_min_expr (AST.PrimLit "0")
569 let gen_scheme = AST.ForGn n_id gen_range
570 -- Make the intermediate vector
571 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
572 -- Create the generate statement
573 cells' <- sequence [genFirstCell, genOtherCell]
574 let (cells, useds) = unzip cells'
575 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
576 -- Assign tmp[len-1] or tmp[0] to res
577 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
578 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
579 (mkIndexedName tmp_name (AST.PrimLit "0")))
580 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
581 return ([AST.CSBSm block], concat useds)
583 -- An id for the counter
584 n_id = mkVHDLBasicId "n"
585 n_cur = idToVHDLExpr n_id
586 -- An expression for previous n
587 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
588 else (n_cur AST.:+: (AST.PrimLit "1"))
589 -- An id for the tmp result vector
590 tmp_id = mkVHDLBasicId "tmp"
591 tmp_name = AST.NSimple tmp_id
592 -- Generate parts of the fold
593 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
595 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
596 let cond_label = mkVHDLExtId "firstcell"
597 -- if n == 0 or n == len-1
598 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
599 else (AST.PrimLit $ show (len-1)))
600 -- Output to tmp[current n]
601 let resname = mkIndexedName tmp_name n_cur
603 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
604 -- Input from vec[current n]
605 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
606 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
607 [Right argexpr1, Right argexpr2]
609 [Right argexpr2, Right argexpr1]
611 -- Return the conditional generate part
612 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
615 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
616 let cond_label = mkVHDLExtId "othercell"
617 -- if n > 0 or n < len-1
618 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
619 else (AST.PrimLit $ show (len-1)))
620 -- Output to tmp[current n]
621 let resname = mkIndexedName tmp_name n_cur
622 -- Input from tmp[previous n]
623 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
624 -- Input from vec[current n]
625 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
626 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
627 [Right argexpr1, Right argexpr2]
629 [Right argexpr2, Right argexpr1]
631 -- Return the conditional generate part
632 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
634 -- | Generate a generate statement for the builtin function "zip"
635 genZip :: BuiltinBuilder
636 genZip = genNoInsts $ genVarArgs genZip'
637 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
638 genZip' (Left res) f args@[arg1, arg2] = do {
639 -- Setup the generate scheme
640 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
641 -- TODO: Use something better than varToString
642 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
643 ; n_id = mkVHDLBasicId "n"
644 ; n_expr = idToVHDLExpr n_id
645 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
646 ; genScheme = AST.ForGn n_id range
647 ; resname' = mkIndexedName (varToVHDLName res) n_expr
648 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
649 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
651 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
652 ; let { resnameA = mkSelectedName resname' (labels!!0)
653 ; resnameB = mkSelectedName resname' (labels!!1)
654 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
655 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
657 -- Return the generate functions
658 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
661 -- | Generate a generate statement for the builtin function "fst"
662 genFst :: BuiltinBuilder
663 genFst = genNoInsts $ genVarArgs genFst'
664 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
665 genFst' (Left res) f args@[arg] = do {
666 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
667 ; let { argexpr' = varToVHDLName arg
668 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
669 ; assign = mkUncondAssign (Left res) argexprA
671 -- Return the generate functions
675 -- | Generate a generate statement for the builtin function "snd"
676 genSnd :: BuiltinBuilder
677 genSnd = genNoInsts $ genVarArgs genSnd'
678 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
679 genSnd' (Left res) f args@[arg] = do {
680 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
681 ; let { argexpr' = varToVHDLName arg
682 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
683 ; assign = mkUncondAssign (Left res) argexprB
685 -- Return the generate functions
689 -- | Generate a generate statement for the builtin function "unzip"
690 genUnzip :: BuiltinBuilder
691 genUnzip = genNoInsts $ genVarArgs genUnzip'
692 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
693 genUnzip' (Left res) f args@[arg] = do {
694 -- Setup the generate scheme
695 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
696 -- TODO: Use something better than varToString
697 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
698 ; n_id = mkVHDLBasicId "n"
699 ; n_expr = idToVHDLExpr n_id
700 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
701 ; genScheme = AST.ForGn n_id range
702 ; resname' = varToVHDLName res
703 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
705 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
706 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
707 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
708 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
709 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
710 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
711 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
712 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
714 -- Return the generate functions
715 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
718 genCopy :: BuiltinBuilder
719 genCopy = genNoInsts $ genVarArgs genCopy'
720 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
721 genCopy' (Left res) f args@[arg] =
723 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
724 (AST.PrimName $ (varToVHDLName arg))]
725 out_assign = mkUncondAssign (Left res) resExpr
729 genConcat :: BuiltinBuilder
730 genConcat = genNoInsts $ genVarArgs genConcat'
731 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
732 genConcat' (Left res) f args@[arg] = do {
733 -- Setup the generate scheme
734 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
735 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
736 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
737 -- TODO: Use something better than varToString
738 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
739 ; n_id = mkVHDLBasicId "n"
740 ; n_expr = idToVHDLExpr n_id
741 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
742 ; genScheme = AST.ForGn n_id range
743 -- Create the content of the generate statement: Applying the mapped_f to
744 -- each of the elements in arg, storing to each element in res
745 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
746 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
747 ; resname = vecSlice fromRange toRange
748 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
749 ; out_assign = mkUncondAssign (Right resname) argexpr
751 -- Return the generate statement
752 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
755 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
756 (AST.ToRange init last))
758 genIteraten :: BuiltinBuilder
759 genIteraten dst f args = genIterate dst f (tail args)
761 genIterate :: BuiltinBuilder
762 genIterate = genIterateOrGenerate True
764 genGeneraten :: BuiltinBuilder
765 genGeneraten dst f args = genGenerate dst f (tail args)
767 genGenerate :: BuiltinBuilder
768 genGenerate = genIterateOrGenerate False
770 genIterateOrGenerate :: Bool -> BuiltinBuilder
771 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
773 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
774 genIterateOrGenerate' iter (Left res) f args = do
775 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
776 genIterateOrGenerate'' len iter (Left res) f args
778 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
779 -- Special case for an empty input vector, just assign start to res
780 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
782 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
784 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
785 -- An expression for len-1
786 let len_min_expr = (AST.PrimLit $ show (len-1))
787 -- -- evec is (TFVec n), so it still needs an element type
788 -- let (nvec, _) = splitAppTy (Var.varType vec)
789 -- -- Put the type of the start value in nvec, this will be the type of our
790 -- -- temporary vector
791 let tmp_ty = Var.varType res
792 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
793 -- TODO: Handle Nothing
794 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
795 -- Setup the generate scheme
796 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
797 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
798 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
799 let gen_scheme = AST.ForGn n_id gen_range
800 -- Make the intermediate vector
801 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
802 -- Create the generate statement
803 cells' <- sequence [genFirstCell, genOtherCell]
804 let (cells, useds) = unzip cells'
805 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
806 -- Assign tmp[len-1] or tmp[0] to res
807 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
808 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
809 return ([AST.CSBSm block], concat useds)
811 -- An id for the counter
812 n_id = mkVHDLBasicId "n"
813 n_cur = idToVHDLExpr n_id
814 -- An expression for previous n
815 n_prev = n_cur AST.:-: (AST.PrimLit "1")
816 -- An id for the tmp result vector
817 tmp_id = mkVHDLBasicId "tmp"
818 tmp_name = AST.NSimple tmp_id
819 -- Generate parts of the fold
820 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
822 let cond_label = mkVHDLExtId "firstcell"
823 -- if n == 0 or n == len-1
824 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
825 -- Output to tmp[current n]
826 let resname = mkIndexedName tmp_name n_cur
828 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
829 let startassign = mkUncondAssign (Right resname) argexpr
830 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
831 -- Return the conditional generate part
832 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
840 let cond_label = mkVHDLExtId "othercell"
841 -- if n > 0 or n < len-1
842 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
843 -- Output to tmp[current n]
844 let resname = mkIndexedName tmp_name n_cur
845 -- Input from tmp[previous n]
846 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
847 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
848 -- Return the conditional generate part
849 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
851 genBlockRAM :: BuiltinBuilder
852 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
854 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
855 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
857 let (tup,data_out) = Type.splitAppTy (Var.varType res)
858 let (tup',ramvec) = Type.splitAppTy tup
859 let Just realram = Type.coreView ramvec
860 let Just (tycon, types) = Type.splitTyConApp_maybe realram
861 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
862 -- Make the intermediate vector
863 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
864 -- Get the data_out name
865 reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
866 let resname' = varToVHDLName res
867 let resname = mkSelectedName resname' (reslabels!!0)
868 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
869 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
870 let assign = mkUncondAssign (Right resname) argexpr
871 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
872 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
873 return [AST.CSBSm block]
875 ram_id = mkVHDLBasicId "ram"
876 mkUpdateProcSm :: AST.ConcSm
877 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
879 proclabel = mkVHDLBasicId "updateRAM"
880 rising_edge = mkVHDLBasicId "rising_edge"
881 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
882 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
883 wform = AST.Wform [AST.WformElem data_in Nothing]
884 ramassign = AST.SigAssign ramloc wform
885 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
886 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
888 -----------------------------------------------------------------------------
889 -- Function to generate VHDL for applications
890 -----------------------------------------------------------------------------
892 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
893 -> CoreSyn.CoreBndr -- ^ The function to apply
894 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
895 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
896 -- ^ The corresponding VHDL concurrent statements and entities
898 genApplication dst f args = do
899 case Var.isGlobalId f of
901 top <- isTopLevelBinder f
904 -- Local binder that references a top level binding. Generate a
905 -- component instantiation.
906 signature <- getEntity f
907 args' <- argsToVHDLExprs args
908 let entity_id = ent_id signature
909 -- TODO: Using show here isn't really pretty, but we'll need some
910 -- unique-ish value...
911 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
912 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
913 return ([mkComponentInst label entity_id portmaps], [f])
915 -- Not a top level binder, so this must be a local variable reference.
916 -- It should have a representable type (and thus, no arguments) and a
917 -- signal should be generated for it. Just generate an unconditional
919 f' <- MonadState.lift tsType $ varToVHDLExpr f
920 return $ ([mkUncondAssign dst f'], [])
922 case Var.idDetails f of
923 IdInfo.DataConWorkId dc -> case dst of
924 -- It's a datacon. Create a record from its arguments.
926 -- We have the bndr, so we can get at the type
927 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
928 args' <- argsToVHDLExprs args
929 return $ (zipWith mkassign labels $ args', [])
931 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
933 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
934 mkUncondAssign (Right sel_name) arg
935 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
936 IdInfo.DataConWrapId dc -> case dst of
937 -- It's a datacon. Create a record from its arguments.
939 case (Map.lookup (varToString f) globalNameTable) of
940 Just (arg_count, builder) ->
941 if length args == arg_count then
944 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
945 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
946 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
947 IdInfo.VanillaId -> do
948 -- It's a global value imported from elsewhere. These can be builtin
949 -- functions. Look up the function name in the name table and execute
950 -- the associated builder if there is any and the argument count matches
951 -- (this should always be the case if it typechecks, but just to be
953 case (Map.lookup (varToString f) globalNameTable) of
954 Just (arg_count, builder) ->
955 if length args == arg_count then
958 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
960 top <- isTopLevelBinder f
963 -- Local binder that references a top level binding. Generate a
964 -- component instantiation.
965 signature <- getEntity f
966 args' <- argsToVHDLExprs args
967 let entity_id = ent_id signature
968 -- TODO: Using show here isn't really pretty, but we'll need some
969 -- unique-ish value...
970 let label = "comp_ins_" ++ (either show prettyShow) dst
971 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
972 return ([mkComponentInst label entity_id portmaps], [f])
974 -- Not a top level binder, so this must be a local variable reference.
975 -- It should have a representable type (and thus, no arguments) and a
976 -- signal should be generated for it. Just generate an unconditional
978 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
979 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
980 -- return $ ([mkUncondAssign dst f'], [])
981 error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
982 IdInfo.ClassOpId cls -> do
983 -- FIXME: Not looking for what instance this class op is called for
984 -- Is quite stupid of course.
985 case (Map.lookup (varToString f) globalNameTable) of
986 Just (arg_count, builder) ->
987 if length args == arg_count then
990 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
991 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
992 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
994 -----------------------------------------------------------------------------
995 -- Functions to generate functions dealing with vectors.
996 -----------------------------------------------------------------------------
998 -- Returns the VHDLId of the vector function with the given name for the given
999 -- element type. Generates -- this function if needed.
1000 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1001 vectorFunId el_ty fname = do
1002 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1003 -- TODO: Handle the Nothing case?
1004 Just elemTM <- vhdl_ty error_msg el_ty
1005 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1006 -- the VHDLState or something.
1007 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1008 typefuns <- getA tsTypeFuns
1009 case Map.lookup (OrdType el_ty, fname) typefuns of
1010 -- Function already generated, just return it
1011 Just (id, _) -> return id
1012 -- Function not generated yet, generate it
1014 let functions = genUnconsVectorFuns elemTM vectorTM
1015 case lookup fname functions of
1017 modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
1018 mapM_ (vectorFunId el_ty) (snd body)
1020 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1022 function_id = mkVHDLExtId fname
1024 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1025 -> AST.TypeMark -- ^ type of the vector
1026 -> [(String, (AST.SubProgBody, [String]))]
1027 genUnconsVectorFuns elemTM vectorTM =
1028 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1029 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1030 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1031 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1032 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1033 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1034 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1035 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1036 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1037 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1038 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1039 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1040 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1041 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1042 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1043 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1044 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1045 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1046 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1047 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1048 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1051 ixPar = AST.unsafeVHDLBasicId "ix"
1052 vecPar = AST.unsafeVHDLBasicId "vec"
1053 vec1Par = AST.unsafeVHDLBasicId "vec1"
1054 vec2Par = AST.unsafeVHDLBasicId "vec2"
1055 nPar = AST.unsafeVHDLBasicId "n"
1056 leftPar = AST.unsafeVHDLBasicId "nLeft"
1057 rightPar = AST.unsafeVHDLBasicId "nRight"
1058 iId = AST.unsafeVHDLBasicId "i"
1060 aPar = AST.unsafeVHDLBasicId "a"
1061 fPar = AST.unsafeVHDLBasicId "f"
1062 sPar = AST.unsafeVHDLBasicId "s"
1063 resId = AST.unsafeVHDLBasicId "res"
1064 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1065 AST.IfaceVarDec ixPar unsignedTM] elemTM
1066 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1067 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
1068 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1069 , AST.IfaceVarDec iPar unsignedTM
1070 , AST.IfaceVarDec aPar elemTM
1072 -- variable res : fsvec_x (0 to vec'length-1);
1075 (AST.SubtypeIn vectorTM
1076 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1077 [AST.ToRange (AST.PrimLit "0")
1078 (AST.PrimName (AST.NAttribute $
1079 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1080 (AST.PrimLit "1")) ]))
1082 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1083 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1084 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1085 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1086 vecSlice init last = AST.PrimName (AST.NSlice
1088 (AST.NSimple vecPar)
1089 (AST.ToRange init last)))
1090 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1091 -- return vec(vec'length-1);
1092 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1093 (AST.NSimple vecPar)
1094 [AST.PrimName (AST.NAttribute $
1095 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1096 AST.:-: AST.PrimLit "1"])))
1097 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1098 -- variable res : fsvec_x (0 to vec'length-2);
1101 (AST.SubtypeIn vectorTM
1102 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1103 [AST.ToRange (AST.PrimLit "0")
1104 (AST.PrimName (AST.NAttribute $
1105 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1106 (AST.PrimLit "2")) ]))
1108 -- resAST.:= vec(0 to vec'length-2)
1109 initExpr = AST.NSimple resId AST.:= (vecSlice
1111 (AST.PrimName (AST.NAttribute $
1112 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1113 AST.:-: AST.PrimLit "2"))
1114 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1115 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1116 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1117 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1118 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1120 (Just $ AST.Else [minimumExprRet])
1121 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1122 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1123 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1124 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1125 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1126 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1127 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1128 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1131 (AST.SubtypeIn vectorTM
1132 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1133 [AST.ToRange (AST.PrimLit "0")
1135 (AST.PrimLit "1")) ]))
1137 -- res AST.:= vec(0 to n-1)
1138 takeExpr = AST.NSimple resId AST.:=
1139 (vecSlice (AST.PrimLit "0")
1140 (minLength AST.:-: AST.PrimLit "1"))
1141 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1142 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1143 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1144 -- variable res : fsvec_x (0 to vec'length-n-1);
1147 (AST.SubtypeIn vectorTM
1148 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1149 [AST.ToRange (AST.PrimLit "0")
1150 (AST.PrimName (AST.NAttribute $
1151 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1152 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1154 -- res AST.:= vec(n to vec'length-1)
1155 dropExpr = AST.NSimple resId AST.:= (vecSlice
1156 (AST.PrimName $ AST.NSimple nPar)
1157 (AST.PrimName (AST.NAttribute $
1158 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1159 AST.:-: AST.PrimLit "1"))
1160 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1161 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1162 AST.IfaceVarDec vecPar vectorTM] vectorTM
1163 -- variable res : fsvec_x (0 to vec'length);
1166 (AST.SubtypeIn vectorTM
1167 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1168 [AST.ToRange (AST.PrimLit "0")
1169 (AST.PrimName (AST.NAttribute $
1170 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1172 plusgtExpr = AST.NSimple resId AST.:=
1173 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1174 (AST.PrimName $ AST.NSimple vecPar))
1175 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1176 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1179 (AST.SubtypeIn vectorTM
1180 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1181 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1183 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1184 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1186 -- variable res : fsvec_x (0 to 0) := (others => a);
1189 (AST.SubtypeIn vectorTM
1190 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1191 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1192 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1193 (AST.PrimName $ AST.NSimple aPar)])
1194 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1195 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1196 AST.IfaceVarDec aPar elemTM ] vectorTM
1197 -- variable res : fsvec_x (0 to n-1) := (others => a);
1200 (AST.SubtypeIn vectorTM
1201 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1202 [AST.ToRange (AST.PrimLit "0")
1203 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1204 (AST.PrimLit "1")) ]))
1205 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1206 (AST.PrimName $ AST.NSimple aPar)])
1208 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1209 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1210 AST.IfaceVarDec sPar naturalTM,
1211 AST.IfaceVarDec nPar naturalTM,
1212 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1213 -- variable res : fsvec_x (0 to n-1);
1216 (AST.SubtypeIn vectorTM
1217 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1218 [AST.ToRange (AST.PrimLit "0")
1219 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1220 (AST.PrimLit "1")) ])
1223 -- for i res'range loop
1224 -- res(i) := vec(f+i*s);
1226 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1227 -- res(i) := vec(f+i*s);
1228 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1229 (AST.PrimName (AST.NSimple iId) AST.:*:
1230 AST.PrimName (AST.NSimple sPar)) in
1231 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1232 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1234 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1235 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1236 AST.IfaceVarDec aPar elemTM] vectorTM
1237 -- variable res : fsvec_x (0 to vec'length);
1240 (AST.SubtypeIn vectorTM
1241 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1242 [AST.ToRange (AST.PrimLit "0")
1243 (AST.PrimName (AST.NAttribute $
1244 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1246 ltplusExpr = AST.NSimple resId AST.:=
1247 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1248 (AST.PrimName $ AST.NSimple aPar))
1249 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1250 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1251 AST.IfaceVarDec vec2Par vectorTM]
1253 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1256 (AST.SubtypeIn vectorTM
1257 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1258 [AST.ToRange (AST.PrimLit "0")
1259 (AST.PrimName (AST.NAttribute $
1260 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1261 AST.PrimName (AST.NAttribute $
1262 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1265 plusplusExpr = AST.NSimple resId AST.:=
1266 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1267 (AST.PrimName $ AST.NSimple vec2Par))
1268 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1269 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1270 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1271 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1272 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1273 AST.IfaceVarDec aPar elemTM ] vectorTM
1274 -- variable res : fsvec_x (0 to vec'length-1);
1277 (AST.SubtypeIn vectorTM
1278 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1279 [AST.ToRange (AST.PrimLit "0")
1280 (AST.PrimName (AST.NAttribute $
1281 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1282 (AST.PrimLit "1")) ]))
1284 -- res := a & init(vec)
1285 shiftlExpr = AST.NSimple resId AST.:=
1286 (AST.PrimName (AST.NSimple aPar) AST.:&:
1287 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1288 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1289 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1290 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1291 AST.IfaceVarDec aPar elemTM ] vectorTM
1292 -- variable res : fsvec_x (0 to vec'length-1);
1295 (AST.SubtypeIn vectorTM
1296 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1297 [AST.ToRange (AST.PrimLit "0")
1298 (AST.PrimName (AST.NAttribute $
1299 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1300 (AST.PrimLit "1")) ]))
1302 -- res := tail(vec) & a
1303 shiftrExpr = AST.NSimple resId AST.:=
1304 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1305 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1306 (AST.PrimName (AST.NSimple aPar)))
1308 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1309 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1310 -- return vec'length = 0
1311 nullExpr = AST.ReturnSm (Just $
1312 AST.PrimName (AST.NAttribute $
1313 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1315 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1316 -- variable res : fsvec_x (0 to vec'length-1);
1319 (AST.SubtypeIn vectorTM
1320 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1321 [AST.ToRange (AST.PrimLit "0")
1322 (AST.PrimName (AST.NAttribute $
1323 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1324 (AST.PrimLit "1")) ]))
1326 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1327 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1328 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1329 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1331 (Just $ AST.Else [rotlExprRet])
1333 AST.NSimple resId AST.:=
1334 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1335 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1336 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1337 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1338 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1339 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1340 -- variable res : fsvec_x (0 to vec'length-1);
1343 (AST.SubtypeIn vectorTM
1344 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1345 [AST.ToRange (AST.PrimLit "0")
1346 (AST.PrimName (AST.NAttribute $
1347 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1348 (AST.PrimLit "1")) ]))
1350 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1351 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1352 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1353 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1355 (Just $ AST.Else [rotrExprRet])
1357 AST.NSimple resId AST.:=
1358 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1359 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1360 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1361 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1362 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1363 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1366 (AST.SubtypeIn vectorTM
1367 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1368 [AST.ToRange (AST.PrimLit "0")
1369 (AST.PrimName (AST.NAttribute $
1370 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1371 (AST.PrimLit "1")) ]))
1373 -- for i in 0 to res'range loop
1374 -- res(vec'length-i-1) := vec(i);
1377 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1378 -- res(vec'length-i-1) := vec(i);
1379 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1380 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1381 [AST.PrimName $ AST.NSimple iId]))
1382 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1383 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1384 AST.PrimName (AST.NSimple iId) AST.:-:
1387 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1390 -----------------------------------------------------------------------------
1391 -- A table of builtin functions
1392 -----------------------------------------------------------------------------
1394 -- A function that generates VHDL for a builtin function
1395 type BuiltinBuilder =
1396 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1397 -> CoreSyn.CoreBndr -- ^ The function called
1398 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1399 -- dictionary arguments).
1400 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1401 -- ^ The corresponding VHDL concurrent statements and entities
1404 -- A map of a builtin function to VHDL function builder
1405 type NameTable = Map.Map String (Int, BuiltinBuilder )
1407 -- | The builtin functions we support. Maps a name to an argument count and a
1408 -- builder function.
1409 globalNameTable :: NameTable
1410 globalNameTable = Map.fromList
1411 [ (exId , (2, genFCall True ) )
1412 , (replaceId , (3, genFCall False ) )
1413 , (headId , (1, genFCall True ) )
1414 , (lastId , (1, genFCall True ) )
1415 , (tailId , (1, genFCall False ) )
1416 , (initId , (1, genFCall False ) )
1417 , (takeId , (2, genFCall False ) )
1418 , (dropId , (2, genFCall False ) )
1419 , (selId , (4, genFCall False ) )
1420 , (plusgtId , (2, genFCall False ) )
1421 , (ltplusId , (2, genFCall False ) )
1422 , (plusplusId , (2, genFCall False ) )
1423 , (mapId , (2, genMap ) )
1424 , (zipWithId , (3, genZipWith ) )
1425 , (foldlId , (3, genFoldl ) )
1426 , (foldrId , (3, genFoldr ) )
1427 , (zipId , (2, genZip ) )
1428 , (unzipId , (1, genUnzip ) )
1429 , (shiftlId , (2, genFCall False ) )
1430 , (shiftrId , (2, genFCall False ) )
1431 , (rotlId , (1, genFCall False ) )
1432 , (rotrId , (1, genFCall False ) )
1433 , (concatId , (1, genConcat ) )
1434 , (reverseId , (1, genFCall False ) )
1435 , (iteratenId , (3, genIteraten ) )
1436 , (iterateId , (2, genIterate ) )
1437 , (generatenId , (3, genGeneraten ) )
1438 , (generateId , (2, genGenerate ) )
1439 , (emptyId , (0, genFCall False ) )
1440 , (singletonId , (1, genFCall False ) )
1441 , (copynId , (2, genFCall False ) )
1442 , (copyId , (1, genCopy ) )
1443 , (lengthTId , (1, genFCall False ) )
1444 , (nullId , (1, genFCall False ) )
1445 , (hwxorId , (2, genOperator2 AST.Xor ) )
1446 , (hwandId , (2, genOperator2 AST.And ) )
1447 , (hworId , (2, genOperator2 AST.Or ) )
1448 , (hwnotId , (1, genOperator1 AST.Not ) )
1449 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1450 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1451 , (ltId , (2, genOperator2 (AST.:<:) ) )
1452 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1453 , (gtId , (2, genOperator2 (AST.:>:) ) )
1454 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1455 , (boolOrId , (2, genOperator2 AST.Or ) )
1456 , (boolAndId , (2, genOperator2 AST.And ) )
1457 , (plusId , (2, genOperator2 (AST.:+:) ) )
1458 , (timesId , (2, genOperator2 (AST.:*:) ) )
1459 , (negateId , (1, genNegation ) )
1460 , (minusId , (2, genOperator2 (AST.:-:) ) )
1461 , (fromSizedWordId , (1, genFromSizedWord ) )
1462 , (fromIntegerId , (1, genFromInteger ) )
1463 , (resizeId , (1, genResize ) )
1464 , (sizedIntId , (1, genSizedInt ) )
1465 , (smallIntegerId , (1, genFromInteger ) )
1466 , (fstId , (1, genFst ) )
1467 , (sndId , (1, genSnd ) )
1468 , (blockRAMId , (5, genBlockRAM ) )
1469 --, (tfvecId , (1, genTFVec ) )
1470 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))