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)
94 -- Add a clk port if we have state
95 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
96 res_port = fmap (mkIfaceSigDec AST.Out) res
98 -- | Create a port declaration
100 AST.Mode -- ^ The mode for the port (In / Out)
101 -> Port -- ^ The id and type for the port
102 -> AST.IfaceSigDec -- ^ The resulting port declaration
104 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
106 -- | Create an architecture for a given function
108 CoreSyn.CoreBndr -- ^ The function to get an architecture for
109 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
110 -- ^ The architecture for this function
112 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
113 expr <- Normalize.getNormalized fname
114 -- Split the normalized expression
115 let (args, binds, res) = Normalize.splitNormalized expr
117 -- Get the entity for this function
118 signature <- getEntity fname
119 let entity_id = ent_id signature
121 -- Create signal declarations for all binders in the let expression, except
122 -- for the output port (that will already have an output port declared in
124 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
125 let sig_decs = Maybe.catMaybes $ sig_dec_maybes
126 -- Process each bind, resulting in info about state variables and concurrent
128 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
129 let (in_state_maybes, out_state_maybes) = unzip state_vars
130 let (statementss, used_entitiess) = unzip sms
131 -- Create a state proc, if needed
132 state_proc <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
133 ([in_state], [out_state]) -> mkStateProcSm (in_state, out_state)
134 ([], []) -> return []
135 (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
136 -- Join the create statements and the (optional) state_proc
137 let statements = concat statementss ++ state_proc
138 -- Create the architecture
139 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
140 let used_entities = concat used_entitiess
141 return (arch, used_entities)
143 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
144 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
145 -- ^ ((Input state variable, output state variable), (statements, used entities))
146 -- newtype unpacking is just a cast
147 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
148 | hasStateType packed && not (hasStateType unpacked)
149 = return ((Just bndr, Nothing), ([], []))
150 -- With simplCore, newtype packing is just a cast
151 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
152 | hasStateType packed && not (hasStateType unpacked)
153 = return ((Nothing, Just state), ([], []))
154 -- Without simplCore, newtype packing uses a data constructor
155 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
157 = return ((Nothing, Just state), ([], []))
158 -- Anything else is handled by mkConcSm
161 return ((Nothing, Nothing), sms)
164 (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
165 -> TranslatorSession [AST.ConcSm] -- ^ The resulting statements
166 mkStateProcSm (old, new) = do
167 nonempty <- hasNonEmptyType old
169 then return [AST.CSPSm $ AST.ProcSm label [clk] [statement]]
172 label = mkVHDLBasicId $ "state"
173 clk = mkVHDLBasicId "clock"
174 rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
175 wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
176 assign = AST.SigAssign (varToVHDLName old) wform
177 rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
178 statement = AST.IfSm rising_edge_clk [assign] [] Nothing
181 -- | Transforms a core binding into a VHDL concurrent statement
183 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
184 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
185 -- ^ The corresponding VHDL concurrent statements and entities
189 -- Ignore Cast expressions, they should not longer have any meaning as long as
190 -- the type works out.
191 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
193 -- Simple a = b assignments are just like applications, but without arguments.
194 -- We can't just generate an unconditional assignment here, since b might be a
195 -- top level binding (e.g., a function with no arguments).
196 mkConcSm (bndr, CoreSyn.Var v) = do
197 genApplication (Left bndr) v []
199 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
200 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
201 let valargs = get_val_args (Var.varType f) args
202 genApplication (Left bndr) f (map Left valargs)
204 -- A single alt case must be a selector. This means thee scrutinee is a simple
205 -- variable, the alternative is a dataalt with a single non-wild binder that
207 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
208 -- Don't generate VHDL for substate extraction
209 | hasStateType bndr = return ([], [])
212 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
213 bndrs' <- Monad.filterM hasNonEmptyType bndrs
214 case List.elemIndex sel_bndr bndrs' of
216 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
217 let label = labels!!i
218 let sel_name = mkSelectedName (varToVHDLName scrut) label
219 let sel_expr = AST.PrimName sel_name
220 return ([mkUncondAssign (Left bndr) sel_expr], [])
221 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
223 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
225 -- Multiple case alt are be conditional assignments and have only wild
226 -- binders in the alts and only variables in the case values and a variable
227 -- for a scrutinee. We check the constructor of the second alt, since the
228 -- first is the default case, if there is any.
229 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
230 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
231 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
232 true_expr <- MonadState.lift tsType $ varToVHDLExpr true
233 false_expr <- MonadState.lift tsType $ varToVHDLExpr false
234 return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
236 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
237 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
238 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
240 -----------------------------------------------------------------------------
241 -- Functions to generate VHDL for builtin functions
242 -----------------------------------------------------------------------------
244 -- | A function to wrap a builder-like function that expects its arguments to
246 genExprArgs wrap dst func args = do
247 args' <- argsToVHDLExprs args
250 -- | Turn the all lefts into VHDL Expressions.
251 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
252 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
254 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
255 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
256 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
257 ty_maybe <- vhdl_ty errmsg expr
260 vhdl_expr <- varToVHDLExpr $ exprToVar expr
261 return $ Just vhdl_expr
262 Nothing -> return $ Nothing
264 argToVHDLExpr (Right expr) = return $ Just expr
266 -- A function to wrap a builder-like function that generates no component
269 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
270 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
271 genNoInsts wrap dst func args = do
272 concsms <- wrap dst func args
275 -- | A function to wrap a builder-like function that expects its arguments to
278 (dst -> func -> [Var.Var] -> res)
279 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
280 genVarArgs wrap dst func args = wrap dst func args'
282 args' = map exprToVar exprargs
283 -- Check (rather crudely) that all arguments are CoreExprs
284 (exprargs, []) = Either.partitionEithers args
286 -- | A function to wrap a builder-like function that expects its arguments to
289 (dst -> func -> [Literal.Literal] -> res)
290 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
291 genLitArgs wrap dst func args = wrap dst func args'
293 args' = map exprToLit litargs
294 -- FIXME: Check if we were passed an CoreSyn.App
295 litargs = concat (map getLiterals exprargs)
296 (exprargs, []) = Either.partitionEithers args
298 -- | A function to wrap a builder-like function that produces an expression
299 -- and expects it to be assigned to the destination.
301 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
302 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
303 genExprRes wrap dst func args = do
304 expr <- wrap dst func args
305 return $ [mkUncondAssign dst expr]
307 -- | Generate a binary operator application. The first argument should be a
308 -- constructor from the AST.Expr type, e.g. AST.And.
309 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
310 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
311 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
312 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
314 -- | Generate a unary operator application
315 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
316 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
317 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
318 genOperator1' op _ f [arg] = return $ op arg
320 -- | Generate a unary operator application
321 genNegation :: BuiltinBuilder
322 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
323 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
324 genNegation' _ f [arg] = do
325 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
326 let ty = Var.varType arg
327 let (tycon, args) = Type.splitTyConApp ty
328 let name = Name.getOccString (TyCon.tyConName tycon)
330 "SizedInt" -> return $ AST.Neg arg1
331 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
333 -- | Generate a function call from the destination binder, function name and a
334 -- list of expressions (its arguments)
335 genFCall :: Bool -> BuiltinBuilder
336 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
337 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
338 genFCall' switch (Left res) f args = do
339 let fname = varToString f
340 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
341 id <- MonadState.lift tsType $ vectorFunId el_ty fname
342 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
343 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
344 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
346 genFromSizedWord :: BuiltinBuilder
347 genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
348 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
349 genFromSizedWord' (Left res) f args = do
350 let fname = varToString f
351 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
352 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
353 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
355 genResize :: BuiltinBuilder
356 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
357 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
358 genResize' (Left res) f [arg] = do {
359 ; let { ty = Var.varType res
360 ; (tycon, args) = Type.splitTyConApp ty
361 ; name = Name.getOccString (TyCon.tyConName tycon)
363 ; len <- case name of
364 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
365 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
366 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
367 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
369 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
371 -- FIXME: I'm calling genLitArgs which is very specific function,
372 -- which needs to be fixed as well
373 genFromInteger :: BuiltinBuilder
374 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
375 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
376 genFromInteger' (Left res) f lits = do {
377 ; let { ty = Var.varType res
378 ; (tycon, args) = Type.splitTyConApp ty
379 ; name = Name.getOccString (TyCon.tyConName tycon)
382 "RangedWord" -> return $ AST.PrimLit (show (last lits))
384 ; len <- case name of
385 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
386 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
387 "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
388 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
389 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
390 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
394 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
396 genSizedInt :: BuiltinBuilder
397 genSizedInt = genFromInteger
400 -- | Generate a Builder for the builtin datacon TFVec
401 genTFVec :: BuiltinBuilder
402 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
403 -- Generate Assignments for all the binders
404 ; letAssigns <- mapM genBinderAssign letBinders
405 -- Generate assignments for the result (which might be another let binding)
406 ; (resBinders,resAssignments) <- genResAssign letRes
407 -- Get all the Assigned binders
408 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
409 -- Make signal names for all the assigned binders
410 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
411 -- Assign all the signals to the resulting vector
412 ; let { vecsigns = mkAggregateSignal sigs
413 ; vecassign = mkUncondAssign (Left res) vecsigns
415 -- Generate all the signal declaration for the assigned binders
416 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
417 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
418 -- Setup the VHDL Block
419 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
420 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
422 -- Return the block statement coressponding to the TFVec literal
423 ; return $ [AST.CSBSm block]
426 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
427 -- For now we only translate applications
428 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
429 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
430 let valargs = get_val_args (Var.varType f) args
431 apps <- genApplication (Left bndr) f (map Left valargs)
432 return (Just bndr, apps)
433 genBinderAssign _ = return (Nothing,[])
434 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
435 genResAssign app@(CoreSyn.App _ letexpr) = do
437 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
438 letapps <- mapM genBinderAssign letbndrs
439 let bndrs = Maybe.catMaybes (map fst letapps)
440 let app = (map snd letapps)
441 (vars, apps) <- genResAssign letres
442 return ((bndrs ++ vars),((concat app) ++ apps))
443 otherwise -> return ([],[])
444 genResAssign _ = return ([],[])
446 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
447 ; let { elems = reduceCoreListToHsList app
448 -- Make signal names for all the binders
449 ; binders = map (\expr -> case expr of
451 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
452 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
454 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
455 -- Assign all the signals to the resulting vector
456 ; let { vecsigns = mkAggregateSignal sigs
457 ; vecassign = mkUncondAssign (Left res) vecsigns
458 -- Setup the VHDL Block
459 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
460 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
462 -- Return the block statement coressponding to the TFVec literal
463 ; return $ [AST.CSBSm block]
466 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
468 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
470 -- | Generate a generate statement for the builtin function "map"
471 genMap :: BuiltinBuilder
472 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
473 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
474 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
475 -- we must index it (which we couldn't if it was a VHDL Expr, since only
476 -- VHDLNames can be indexed).
477 -- Setup the generate scheme
478 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
479 -- TODO: Use something better than varToString
480 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
481 ; n_id = mkVHDLBasicId "n"
482 ; n_expr = idToVHDLExpr n_id
483 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
484 ; genScheme = AST.ForGn n_id range
485 -- Create the content of the generate statement: Applying the mapped_f to
486 -- each of the elements in arg, storing to each element in res
487 ; resname = mkIndexedName (varToVHDLName res) n_expr
488 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
489 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
490 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
492 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
493 -- Return the generate statement
494 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
497 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
499 genZipWith :: BuiltinBuilder
500 genZipWith = genVarArgs genZipWith'
501 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
502 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
503 -- Setup the generate scheme
504 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
505 -- TODO: Use something better than varToString
506 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
507 ; n_id = mkVHDLBasicId "n"
508 ; n_expr = idToVHDLExpr n_id
509 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
510 ; genScheme = AST.ForGn n_id range
511 -- Create the content of the generate statement: Applying the zipped_f to
512 -- each of the elements in arg1 and arg2, storing to each element in res
513 ; resname = mkIndexedName (varToVHDLName res) n_expr
514 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
515 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
517 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
518 -- Return the generate functions
519 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
522 genFoldl :: BuiltinBuilder
523 genFoldl = genFold True
525 genFoldr :: BuiltinBuilder
526 genFoldr = genFold False
528 genFold :: Bool -> BuiltinBuilder
529 genFold left = genVarArgs (genFold' left)
531 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
532 genFold' left res f args@[folded_f , start ,vec]= do
533 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
534 genFold'' len left res f args
536 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
537 -- Special case for an empty input vector, just assign start to res
538 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
539 arg <- MonadState.lift tsType $ varToVHDLExpr start
540 return ([mkUncondAssign (Left res) arg], [])
542 genFold'' len left (Left res) f [folded_f, start, vec] = do
544 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
545 -- An expression for len-1
546 let len_min_expr = (AST.PrimLit $ show (len-1))
547 -- evec is (TFVec n), so it still needs an element type
548 let (nvec, _) = Type.splitAppTy (Var.varType vec)
549 -- Put the type of the start value in nvec, this will be the type of our
551 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
552 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
553 -- TODO: Handle Nothing
554 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
555 -- Setup the generate scheme
556 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
557 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
558 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
559 else AST.DownRange len_min_expr (AST.PrimLit "0")
560 let gen_scheme = AST.ForGn n_id gen_range
561 -- Make the intermediate vector
562 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
563 -- Create the generate statement
564 cells' <- sequence [genFirstCell, genOtherCell]
565 let (cells, useds) = unzip cells'
566 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
567 -- Assign tmp[len-1] or tmp[0] to res
568 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
569 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
570 (mkIndexedName tmp_name (AST.PrimLit "0")))
571 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
572 return ([AST.CSBSm block], concat useds)
574 -- An id for the counter
575 n_id = mkVHDLBasicId "n"
576 n_cur = idToVHDLExpr n_id
577 -- An expression for previous n
578 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
579 else (n_cur AST.:+: (AST.PrimLit "1"))
580 -- An id for the tmp result vector
581 tmp_id = mkVHDLBasicId "tmp"
582 tmp_name = AST.NSimple tmp_id
583 -- Generate parts of the fold
584 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
586 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
587 let cond_label = mkVHDLExtId "firstcell"
588 -- if n == 0 or n == len-1
589 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
590 else (AST.PrimLit $ show (len-1)))
591 -- Output to tmp[current n]
592 let resname = mkIndexedName tmp_name n_cur
594 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
595 -- Input from vec[current n]
596 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
597 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
598 [Right argexpr1, Right argexpr2]
600 [Right argexpr2, Right argexpr1]
602 -- Return the conditional generate part
603 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
606 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
607 let cond_label = mkVHDLExtId "othercell"
608 -- if n > 0 or n < len-1
609 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
610 else (AST.PrimLit $ show (len-1)))
611 -- Output to tmp[current n]
612 let resname = mkIndexedName tmp_name n_cur
613 -- Input from tmp[previous n]
614 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
615 -- Input from vec[current n]
616 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
617 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
618 [Right argexpr1, Right argexpr2]
620 [Right argexpr2, Right argexpr1]
622 -- Return the conditional generate part
623 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
625 -- | Generate a generate statement for the builtin function "zip"
626 genZip :: BuiltinBuilder
627 genZip = genNoInsts $ genVarArgs genZip'
628 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
629 genZip' (Left res) f args@[arg1, arg2] = do {
630 -- Setup the generate scheme
631 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
632 -- TODO: Use something better than varToString
633 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
634 ; n_id = mkVHDLBasicId "n"
635 ; n_expr = idToVHDLExpr n_id
636 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
637 ; genScheme = AST.ForGn n_id range
638 ; resname' = mkIndexedName (varToVHDLName res) n_expr
639 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
640 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
642 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
643 ; let { resnameA = mkSelectedName resname' (labels!!0)
644 ; resnameB = mkSelectedName resname' (labels!!1)
645 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
646 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
648 -- Return the generate functions
649 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
652 -- | Generate a generate statement for the builtin function "fst"
653 genFst :: BuiltinBuilder
654 genFst = genNoInsts $ genVarArgs genFst'
655 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
656 genFst' (Left res) f args@[arg] = do {
657 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
658 ; let { argexpr' = varToVHDLName arg
659 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
660 ; assign = mkUncondAssign (Left res) argexprA
662 -- Return the generate functions
666 -- | Generate a generate statement for the builtin function "snd"
667 genSnd :: BuiltinBuilder
668 genSnd = genNoInsts $ genVarArgs genSnd'
669 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
670 genSnd' (Left res) f args@[arg] = do {
671 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
672 ; let { argexpr' = varToVHDLName arg
673 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
674 ; assign = mkUncondAssign (Left res) argexprB
676 -- Return the generate functions
680 -- | Generate a generate statement for the builtin function "unzip"
681 genUnzip :: BuiltinBuilder
682 genUnzip = genNoInsts $ genVarArgs genUnzip'
683 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
684 genUnzip' (Left res) f args@[arg] = do {
685 -- Setup the generate scheme
686 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
687 -- TODO: Use something better than varToString
688 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
689 ; n_id = mkVHDLBasicId "n"
690 ; n_expr = idToVHDLExpr n_id
691 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
692 ; genScheme = AST.ForGn n_id range
693 ; resname' = varToVHDLName res
694 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
696 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
697 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
698 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
699 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
700 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
701 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
702 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
703 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
705 -- Return the generate functions
706 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
709 genCopy :: BuiltinBuilder
710 genCopy = genNoInsts $ genVarArgs genCopy'
711 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
712 genCopy' (Left res) f args@[arg] =
714 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
715 (AST.PrimName $ (varToVHDLName arg))]
716 out_assign = mkUncondAssign (Left res) resExpr
720 genConcat :: BuiltinBuilder
721 genConcat = genNoInsts $ genVarArgs genConcat'
722 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
723 genConcat' (Left res) f args@[arg] = do {
724 -- Setup the generate scheme
725 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
726 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
727 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
728 -- TODO: Use something better than varToString
729 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
730 ; n_id = mkVHDLBasicId "n"
731 ; n_expr = idToVHDLExpr n_id
732 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
733 ; genScheme = AST.ForGn n_id range
734 -- Create the content of the generate statement: Applying the mapped_f to
735 -- each of the elements in arg, storing to each element in res
736 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
737 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
738 ; resname = vecSlice fromRange toRange
739 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
740 ; out_assign = mkUncondAssign (Right resname) argexpr
742 -- Return the generate statement
743 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
746 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
747 (AST.ToRange init last))
749 genIteraten :: BuiltinBuilder
750 genIteraten dst f args = genIterate dst f (tail args)
752 genIterate :: BuiltinBuilder
753 genIterate = genIterateOrGenerate True
755 genGeneraten :: BuiltinBuilder
756 genGeneraten dst f args = genGenerate dst f (tail args)
758 genGenerate :: BuiltinBuilder
759 genGenerate = genIterateOrGenerate False
761 genIterateOrGenerate :: Bool -> BuiltinBuilder
762 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
764 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
765 genIterateOrGenerate' iter (Left res) f args = do
766 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
767 genIterateOrGenerate'' len iter (Left res) f args
769 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
770 -- Special case for an empty input vector, just assign start to res
771 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
773 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
775 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
776 -- An expression for len-1
777 let len_min_expr = (AST.PrimLit $ show (len-1))
778 -- -- evec is (TFVec n), so it still needs an element type
779 -- let (nvec, _) = splitAppTy (Var.varType vec)
780 -- -- Put the type of the start value in nvec, this will be the type of our
781 -- -- temporary vector
782 let tmp_ty = Var.varType res
783 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
784 -- TODO: Handle Nothing
785 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
786 -- Setup the generate scheme
787 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
788 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
789 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
790 let gen_scheme = AST.ForGn n_id gen_range
791 -- Make the intermediate vector
792 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
793 -- Create the generate statement
794 cells' <- sequence [genFirstCell, genOtherCell]
795 let (cells, useds) = unzip cells'
796 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
797 -- Assign tmp[len-1] or tmp[0] to res
798 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
799 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
800 return ([AST.CSBSm block], concat useds)
802 -- An id for the counter
803 n_id = mkVHDLBasicId "n"
804 n_cur = idToVHDLExpr n_id
805 -- An expression for previous n
806 n_prev = n_cur AST.:-: (AST.PrimLit "1")
807 -- An id for the tmp result vector
808 tmp_id = mkVHDLBasicId "tmp"
809 tmp_name = AST.NSimple tmp_id
810 -- Generate parts of the fold
811 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
813 let cond_label = mkVHDLExtId "firstcell"
814 -- if n == 0 or n == len-1
815 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
816 -- Output to tmp[current n]
817 let resname = mkIndexedName tmp_name n_cur
819 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
820 let startassign = mkUncondAssign (Right resname) argexpr
821 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
822 -- Return the conditional generate part
823 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
831 let cond_label = mkVHDLExtId "othercell"
832 -- if n > 0 or n < len-1
833 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
834 -- Output to tmp[current n]
835 let resname = mkIndexedName tmp_name n_cur
836 -- Input from tmp[previous n]
837 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
838 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
839 -- Return the conditional generate part
840 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
842 genBlockRAM :: BuiltinBuilder
843 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
845 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
846 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
848 let (tup,data_out) = Type.splitAppTy (Var.varType res)
849 let (tup',ramvec) = Type.splitAppTy tup
850 let Just realram = Type.coreView ramvec
851 let Just (tycon, types) = Type.splitTyConApp_maybe realram
852 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
853 -- Make the intermediate vector
854 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
855 -- Get the data_out name
856 reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
857 let resname' = varToVHDLName res
858 let resname = mkSelectedName resname' (reslabels!!0)
859 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr
860 let assign = mkUncondAssign (Right resname) argexpr
861 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
862 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
863 return [AST.CSBSm block]
865 ram_id = mkVHDLBasicId "ram"
866 mkUpdateProcSm :: AST.ConcSm
867 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
869 proclabel = mkVHDLBasicId "updateRAM"
870 rising_edge = mkVHDLBasicId "rising_edge"
871 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr
872 wform = AST.Wform [AST.WformElem data_in Nothing]
873 ramassign = AST.SigAssign ramloc wform
874 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
875 statement = AST.IfSm (AST.And rising_edge_clk (wrenable AST.:=: AST.PrimLit "'1'")) [ramassign] [] Nothing
877 -----------------------------------------------------------------------------
878 -- Function to generate VHDL for applications
879 -----------------------------------------------------------------------------
881 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
882 -> CoreSyn.CoreBndr -- ^ The function to apply
883 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
884 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
885 -- ^ The corresponding VHDL concurrent statements and entities
887 genApplication dst f args = do
888 case Var.isGlobalId f of
890 top <- isTopLevelBinder f
893 -- Local binder that references a top level binding. Generate a
894 -- component instantiation.
895 signature <- getEntity f
896 args' <- argsToVHDLExprs args
897 let entity_id = ent_id signature
898 -- TODO: Using show here isn't really pretty, but we'll need some
899 -- unique-ish value...
900 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
901 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
902 return ([mkComponentInst label entity_id portmaps], [f])
904 -- Not a top level binder, so this must be a local variable reference.
905 -- It should have a representable type (and thus, no arguments) and a
906 -- signal should be generated for it. Just generate an unconditional
908 f' <- MonadState.lift tsType $ varToVHDLExpr f
909 return $ ([mkUncondAssign dst f'], [])
911 case Var.idDetails f of
912 IdInfo.DataConWorkId dc -> case dst of
913 -- It's a datacon. Create a record from its arguments.
915 -- We have the bndr, so we can get at the type
916 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
917 args' <- argsToVHDLExprs args
918 return $ (zipWith mkassign labels $ args', [])
920 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
922 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
923 mkUncondAssign (Right sel_name) arg
924 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
925 IdInfo.DataConWrapId dc -> case dst of
926 -- It's a datacon. Create a record from its arguments.
928 case (Map.lookup (varToString f) globalNameTable) of
929 Just (arg_count, builder) ->
930 if length args == arg_count then
933 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
934 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
935 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
936 IdInfo.VanillaId -> do
937 -- It's a global value imported from elsewhere. These can be builtin
938 -- functions. Look up the function name in the name table and execute
939 -- the associated builder if there is any and the argument count matches
940 -- (this should always be the case if it typechecks, but just to be
942 case (Map.lookup (varToString f) globalNameTable) of
943 Just (arg_count, builder) ->
944 if length args == arg_count then
947 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
949 top <- isTopLevelBinder f
952 -- Local binder that references a top level binding. Generate a
953 -- component instantiation.
954 signature <- getEntity f
955 args' <- argsToVHDLExprs args
956 let entity_id = ent_id signature
957 -- TODO: Using show here isn't really pretty, but we'll need some
958 -- unique-ish value...
959 let label = "comp_ins_" ++ (either show prettyShow) dst
960 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
961 return ([mkComponentInst label entity_id portmaps], [f])
963 -- Not a top level binder, so this must be a local variable reference.
964 -- It should have a representable type (and thus, no arguments) and a
965 -- signal should be generated for it. Just generate an unconditional
967 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
968 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
969 -- return $ ([mkUncondAssign dst f'], [])
970 error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
971 IdInfo.ClassOpId cls -> do
972 -- FIXME: Not looking for what instance this class op is called for
973 -- Is quite stupid of course.
974 case (Map.lookup (varToString f) globalNameTable) of
975 Just (arg_count, builder) ->
976 if length args == arg_count then
979 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
980 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
981 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
983 -----------------------------------------------------------------------------
984 -- Functions to generate functions dealing with vectors.
985 -----------------------------------------------------------------------------
987 -- Returns the VHDLId of the vector function with the given name for the given
988 -- element type. Generates -- this function if needed.
989 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
990 vectorFunId el_ty fname = do
991 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
992 -- TODO: Handle the Nothing case?
993 Just elemTM <- vhdl_ty error_msg el_ty
994 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
995 -- the VHDLState or something.
996 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
997 typefuns <- getA tsTypeFuns
998 case Map.lookup (OrdType el_ty, fname) typefuns of
999 -- Function already generated, just return it
1000 Just (id, _) -> return id
1001 -- Function not generated yet, generate it
1003 let functions = genUnconsVectorFuns elemTM vectorTM
1004 case lookup fname functions of
1006 modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
1007 mapM_ (vectorFunId el_ty) (snd body)
1009 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1011 function_id = mkVHDLExtId fname
1013 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1014 -> AST.TypeMark -- ^ type of the vector
1015 -> [(String, (AST.SubProgBody, [String]))]
1016 genUnconsVectorFuns elemTM vectorTM =
1017 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1018 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
1019 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1020 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1021 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1022 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1023 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1024 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1025 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1026 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1027 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1028 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1029 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1030 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1031 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1032 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1033 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1034 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1035 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1036 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1037 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1040 ixPar = AST.unsafeVHDLBasicId "ix"
1041 vecPar = AST.unsafeVHDLBasicId "vec"
1042 vec1Par = AST.unsafeVHDLBasicId "vec1"
1043 vec2Par = AST.unsafeVHDLBasicId "vec2"
1044 nPar = AST.unsafeVHDLBasicId "n"
1045 leftPar = AST.unsafeVHDLBasicId "nLeft"
1046 rightPar = AST.unsafeVHDLBasicId "nRight"
1047 iId = AST.unsafeVHDLBasicId "i"
1049 aPar = AST.unsafeVHDLBasicId "a"
1050 fPar = AST.unsafeVHDLBasicId "f"
1051 sPar = AST.unsafeVHDLBasicId "s"
1052 resId = AST.unsafeVHDLBasicId "res"
1053 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1054 AST.IfaceVarDec ixPar naturalTM] elemTM
1055 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1056 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
1057 AST.NSimple ixPar]))
1058 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1059 , AST.IfaceVarDec iPar naturalTM
1060 , AST.IfaceVarDec aPar elemTM
1062 -- variable res : fsvec_x (0 to vec'length-1);
1065 (AST.SubtypeIn vectorTM
1066 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1067 [AST.ToRange (AST.PrimLit "0")
1068 (AST.PrimName (AST.NAttribute $
1069 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1070 (AST.PrimLit "1")) ]))
1072 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1073 replaceExpr = AST.NSimple resId AST.:=
1074 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
1075 AST.PrimName (AST.NSimple aPar) AST.:&:
1076 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
1077 ((AST.PrimName (AST.NAttribute $
1078 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1079 AST.:-: AST.PrimLit "1"))
1080 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1081 vecSlice init last = AST.PrimName (AST.NSlice
1083 (AST.NSimple vecPar)
1084 (AST.ToRange init last)))
1085 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1086 -- return vec(vec'length-1);
1087 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1088 (AST.NSimple vecPar)
1089 [AST.PrimName (AST.NAttribute $
1090 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1091 AST.:-: AST.PrimLit "1"])))
1092 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1093 -- variable res : fsvec_x (0 to vec'length-2);
1096 (AST.SubtypeIn vectorTM
1097 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1098 [AST.ToRange (AST.PrimLit "0")
1099 (AST.PrimName (AST.NAttribute $
1100 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1101 (AST.PrimLit "2")) ]))
1103 -- resAST.:= vec(0 to vec'length-2)
1104 initExpr = AST.NSimple resId AST.:= (vecSlice
1106 (AST.PrimName (AST.NAttribute $
1107 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1108 AST.:-: AST.PrimLit "2"))
1109 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1110 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1111 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1112 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1113 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1115 (Just $ AST.Else [minimumExprRet])
1116 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1117 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1118 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1119 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1120 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1121 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1122 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1123 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1126 (AST.SubtypeIn vectorTM
1127 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1128 [AST.ToRange (AST.PrimLit "0")
1130 (AST.PrimLit "1")) ]))
1132 -- res AST.:= vec(0 to n-1)
1133 takeExpr = AST.NSimple resId AST.:=
1134 (vecSlice (AST.PrimLit "0")
1135 (minLength AST.:-: AST.PrimLit "1"))
1136 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1137 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1138 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1139 -- variable res : fsvec_x (0 to vec'length-n-1);
1142 (AST.SubtypeIn vectorTM
1143 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1144 [AST.ToRange (AST.PrimLit "0")
1145 (AST.PrimName (AST.NAttribute $
1146 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1147 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1149 -- res AST.:= vec(n to vec'length-1)
1150 dropExpr = AST.NSimple resId AST.:= (vecSlice
1151 (AST.PrimName $ AST.NSimple nPar)
1152 (AST.PrimName (AST.NAttribute $
1153 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1154 AST.:-: AST.PrimLit "1"))
1155 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1156 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1157 AST.IfaceVarDec vecPar vectorTM] vectorTM
1158 -- variable res : fsvec_x (0 to vec'length);
1161 (AST.SubtypeIn vectorTM
1162 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1163 [AST.ToRange (AST.PrimLit "0")
1164 (AST.PrimName (AST.NAttribute $
1165 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1167 plusgtExpr = AST.NSimple resId AST.:=
1168 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1169 (AST.PrimName $ AST.NSimple vecPar))
1170 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1171 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1174 (AST.SubtypeIn vectorTM
1175 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1176 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1178 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1179 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1181 -- variable res : fsvec_x (0 to 0) := (others => a);
1184 (AST.SubtypeIn vectorTM
1185 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1186 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1187 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1188 (AST.PrimName $ AST.NSimple aPar)])
1189 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1190 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1191 AST.IfaceVarDec aPar elemTM ] vectorTM
1192 -- variable res : fsvec_x (0 to n-1) := (others => a);
1195 (AST.SubtypeIn vectorTM
1196 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1197 [AST.ToRange (AST.PrimLit "0")
1198 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1199 (AST.PrimLit "1")) ]))
1200 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1201 (AST.PrimName $ AST.NSimple aPar)])
1203 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1204 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1205 AST.IfaceVarDec sPar naturalTM,
1206 AST.IfaceVarDec nPar naturalTM,
1207 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1208 -- variable res : fsvec_x (0 to n-1);
1211 (AST.SubtypeIn vectorTM
1212 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1213 [AST.ToRange (AST.PrimLit "0")
1214 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1215 (AST.PrimLit "1")) ])
1218 -- for i res'range loop
1219 -- res(i) := vec(f+i*s);
1221 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1222 -- res(i) := vec(f+i*s);
1223 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1224 (AST.PrimName (AST.NSimple iId) AST.:*:
1225 AST.PrimName (AST.NSimple sPar)) in
1226 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1227 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1229 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1230 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1231 AST.IfaceVarDec aPar elemTM] vectorTM
1232 -- variable res : fsvec_x (0 to vec'length);
1235 (AST.SubtypeIn vectorTM
1236 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1237 [AST.ToRange (AST.PrimLit "0")
1238 (AST.PrimName (AST.NAttribute $
1239 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1241 ltplusExpr = AST.NSimple resId AST.:=
1242 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1243 (AST.PrimName $ AST.NSimple aPar))
1244 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1245 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1246 AST.IfaceVarDec vec2Par vectorTM]
1248 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1251 (AST.SubtypeIn vectorTM
1252 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1253 [AST.ToRange (AST.PrimLit "0")
1254 (AST.PrimName (AST.NAttribute $
1255 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1256 AST.PrimName (AST.NAttribute $
1257 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1260 plusplusExpr = AST.NSimple resId AST.:=
1261 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1262 (AST.PrimName $ AST.NSimple vec2Par))
1263 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1264 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1265 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1266 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1267 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1268 AST.IfaceVarDec aPar elemTM ] vectorTM
1269 -- variable res : fsvec_x (0 to vec'length-1);
1272 (AST.SubtypeIn vectorTM
1273 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1274 [AST.ToRange (AST.PrimLit "0")
1275 (AST.PrimName (AST.NAttribute $
1276 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1277 (AST.PrimLit "1")) ]))
1279 -- res := a & init(vec)
1280 shiftlExpr = AST.NSimple resId AST.:=
1281 (AST.PrimName (AST.NSimple aPar) AST.:&:
1282 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1283 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1284 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1285 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1286 AST.IfaceVarDec aPar elemTM ] vectorTM
1287 -- variable res : fsvec_x (0 to vec'length-1);
1290 (AST.SubtypeIn vectorTM
1291 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1292 [AST.ToRange (AST.PrimLit "0")
1293 (AST.PrimName (AST.NAttribute $
1294 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1295 (AST.PrimLit "1")) ]))
1297 -- res := tail(vec) & a
1298 shiftrExpr = AST.NSimple resId AST.:=
1299 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1300 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1301 (AST.PrimName (AST.NSimple aPar)))
1303 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1304 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1305 -- return vec'length = 0
1306 nullExpr = AST.ReturnSm (Just $
1307 AST.PrimName (AST.NAttribute $
1308 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1310 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1311 -- variable res : fsvec_x (0 to vec'length-1);
1314 (AST.SubtypeIn vectorTM
1315 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1316 [AST.ToRange (AST.PrimLit "0")
1317 (AST.PrimName (AST.NAttribute $
1318 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1319 (AST.PrimLit "1")) ]))
1321 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1322 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1323 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1324 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1326 (Just $ AST.Else [rotlExprRet])
1328 AST.NSimple resId AST.:=
1329 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1330 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1331 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1332 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1333 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1334 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1335 -- variable res : fsvec_x (0 to vec'length-1);
1338 (AST.SubtypeIn vectorTM
1339 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1340 [AST.ToRange (AST.PrimLit "0")
1341 (AST.PrimName (AST.NAttribute $
1342 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1343 (AST.PrimLit "1")) ]))
1345 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1346 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1347 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1348 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1350 (Just $ AST.Else [rotrExprRet])
1352 AST.NSimple resId AST.:=
1353 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1354 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1355 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1356 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1357 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1358 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1361 (AST.SubtypeIn vectorTM
1362 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1363 [AST.ToRange (AST.PrimLit "0")
1364 (AST.PrimName (AST.NAttribute $
1365 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1366 (AST.PrimLit "1")) ]))
1368 -- for i in 0 to res'range loop
1369 -- res(vec'length-i-1) := vec(i);
1372 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1373 -- res(vec'length-i-1) := vec(i);
1374 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1375 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1376 [AST.PrimName $ AST.NSimple iId]))
1377 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1378 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1379 AST.PrimName (AST.NSimple iId) AST.:-:
1382 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1385 -----------------------------------------------------------------------------
1386 -- A table of builtin functions
1387 -----------------------------------------------------------------------------
1389 -- A function that generates VHDL for a builtin function
1390 type BuiltinBuilder =
1391 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1392 -> CoreSyn.CoreBndr -- ^ The function called
1393 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1394 -- dictionary arguments).
1395 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1396 -- ^ The corresponding VHDL concurrent statements and entities
1399 -- A map of a builtin function to VHDL function builder
1400 type NameTable = Map.Map String (Int, BuiltinBuilder )
1402 -- | The builtin functions we support. Maps a name to an argument count and a
1403 -- builder function.
1404 globalNameTable :: NameTable
1405 globalNameTable = Map.fromList
1406 [ (exId , (2, genFCall True ) )
1407 , (replaceId , (3, genFCall False ) )
1408 , (headId , (1, genFCall True ) )
1409 , (lastId , (1, genFCall True ) )
1410 , (tailId , (1, genFCall False ) )
1411 , (initId , (1, genFCall False ) )
1412 , (takeId , (2, genFCall False ) )
1413 , (dropId , (2, genFCall False ) )
1414 , (selId , (4, genFCall False ) )
1415 , (plusgtId , (2, genFCall False ) )
1416 , (ltplusId , (2, genFCall False ) )
1417 , (plusplusId , (2, genFCall False ) )
1418 , (mapId , (2, genMap ) )
1419 , (zipWithId , (3, genZipWith ) )
1420 , (foldlId , (3, genFoldl ) )
1421 , (foldrId , (3, genFoldr ) )
1422 , (zipId , (2, genZip ) )
1423 , (unzipId , (1, genUnzip ) )
1424 , (shiftlId , (2, genFCall False ) )
1425 , (shiftrId , (2, genFCall False ) )
1426 , (rotlId , (1, genFCall False ) )
1427 , (rotrId , (1, genFCall False ) )
1428 , (concatId , (1, genConcat ) )
1429 , (reverseId , (1, genFCall False ) )
1430 , (iteratenId , (3, genIteraten ) )
1431 , (iterateId , (2, genIterate ) )
1432 , (generatenId , (3, genGeneraten ) )
1433 , (generateId , (2, genGenerate ) )
1434 , (emptyId , (0, genFCall False ) )
1435 , (singletonId , (1, genFCall False ) )
1436 , (copynId , (2, genFCall False ) )
1437 , (copyId , (1, genCopy ) )
1438 , (lengthTId , (1, genFCall False ) )
1439 , (nullId , (1, genFCall False ) )
1440 , (hwxorId , (2, genOperator2 AST.Xor ) )
1441 , (hwandId , (2, genOperator2 AST.And ) )
1442 , (hworId , (2, genOperator2 AST.Or ) )
1443 , (hwnotId , (1, genOperator1 AST.Not ) )
1444 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1445 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1446 , (boolOrId , (2, genOperator2 AST.Or ) )
1447 , (boolAndId , (2, genOperator2 AST.And ) )
1448 , (plusId , (2, genOperator2 (AST.:+:) ) )
1449 , (timesId , (2, genOperator2 (AST.:*:) ) )
1450 , (negateId , (1, genNegation ) )
1451 , (minusId , (2, genOperator2 (AST.:-:) ) )
1452 , (fromSizedWordId , (1, genFromSizedWord ) )
1453 , (fromIntegerId , (1, genFromInteger ) )
1454 , (resizeId , (1, genResize ) )
1455 , (sizedIntId , (1, genSizedInt ) )
1456 , (smallIntegerId , (1, genFromInteger ) )
1457 , (fstId , (1, genFst ) )
1458 , (sndId , (1, genSnd ) )
1459 , (blockRAMId , (5, genBlockRAM ) )
1460 --, (tfvecId , (1, genTFVec ) )
1461 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))