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. Throw away state repacking
191 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
192 | hasStateType to && hasStateType from
194 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
196 -- Simple a = b assignments are just like applications, but without arguments.
197 -- We can't just generate an unconditional assignment here, since b might be a
198 -- top level binding (e.g., a function with no arguments).
199 mkConcSm (bndr, CoreSyn.Var v) = do
200 genApplication (Left bndr) v []
202 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
203 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
204 let valargs = get_val_args (Var.varType f) args
205 genApplication (Left bndr) f (map Left valargs)
207 -- A single alt case must be a selector. This means thee scrutinee is a simple
208 -- variable, the alternative is a dataalt with a single non-wild binder that
210 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
211 -- Don't generate VHDL for substate extraction
212 | hasStateType bndr = return ([], [])
215 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
216 bndrs' <- Monad.filterM hasNonEmptyType bndrs
217 case List.elemIndex sel_bndr bndrs' of
219 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
220 let label = labels!!i
221 let sel_name = mkSelectedName (varToVHDLName scrut) label
222 let sel_expr = AST.PrimName sel_name
223 return ([mkUncondAssign (Left bndr) sel_expr], [])
224 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
226 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
228 -- Multiple case alt are be conditional assignments and have only wild
229 -- binders in the alts and only variables in the case values and a variable
230 -- for a scrutinee. We check the constructor of the second alt, since the
231 -- first is the default case, if there is any.
232 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
233 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
234 let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
235 true_expr <- MonadState.lift tsType $ varToVHDLExpr true
236 false_expr <- MonadState.lift tsType $ varToVHDLExpr false
237 return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
239 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
240 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
241 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
243 -----------------------------------------------------------------------------
244 -- Functions to generate VHDL for builtin functions
245 -----------------------------------------------------------------------------
247 -- | A function to wrap a builder-like function that expects its arguments to
249 genExprArgs wrap dst func args = do
250 args' <- argsToVHDLExprs args
253 -- | Turn the all lefts into VHDL Expressions.
254 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
255 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
257 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
258 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
259 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
260 ty_maybe <- vhdl_ty errmsg expr
263 vhdl_expr <- varToVHDLExpr $ exprToVar expr
264 return $ Just vhdl_expr
265 Nothing -> return $ Nothing
267 argToVHDLExpr (Right expr) = return $ Just expr
269 -- A function to wrap a builder-like function that generates no component
272 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
273 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
274 genNoInsts wrap dst func args = do
275 concsms <- wrap dst func args
278 -- | A function to wrap a builder-like function that expects its arguments to
281 (dst -> func -> [Var.Var] -> res)
282 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
283 genVarArgs wrap dst func args = wrap dst func args'
285 args' = map exprToVar exprargs
286 -- Check (rather crudely) that all arguments are CoreExprs
287 (exprargs, []) = Either.partitionEithers args
289 -- | A function to wrap a builder-like function that expects its arguments to
292 (dst -> func -> [Literal.Literal] -> res)
293 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
294 genLitArgs wrap dst func args = wrap dst func args'
296 args' = map exprToLit litargs
297 -- FIXME: Check if we were passed an CoreSyn.App
298 litargs = concat (map getLiterals exprargs)
299 (exprargs, []) = Either.partitionEithers args
301 -- | A function to wrap a builder-like function that produces an expression
302 -- and expects it to be assigned to the destination.
304 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
305 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
306 genExprRes wrap dst func args = do
307 expr <- wrap dst func args
308 return $ [mkUncondAssign dst expr]
310 -- | Generate a binary operator application. The first argument should be a
311 -- constructor from the AST.Expr type, e.g. AST.And.
312 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
313 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
314 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
315 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
317 -- | Generate a unary operator application
318 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
319 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
320 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
321 genOperator1' op _ f [arg] = return $ op arg
323 -- | Generate a unary operator application
324 genNegation :: BuiltinBuilder
325 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
326 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
327 genNegation' _ f [arg] = do
328 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
329 let ty = Var.varType arg
330 let (tycon, args) = Type.splitTyConApp ty
331 let name = Name.getOccString (TyCon.tyConName tycon)
333 "SizedInt" -> return $ AST.Neg arg1
334 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
336 -- | Generate a function call from the destination binder, function name and a
337 -- list of expressions (its arguments)
338 genFCall :: Bool -> BuiltinBuilder
339 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
340 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
341 genFCall' switch (Left res) f args = do
342 let fname = varToString f
343 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
344 id <- MonadState.lift tsType $ vectorFunId el_ty fname
345 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
346 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
347 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
349 genFromSizedWord :: BuiltinBuilder
350 genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
351 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
352 genFromSizedWord' (Left res) f args = do
353 let fname = varToString f
354 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
355 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
356 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
358 genResize :: BuiltinBuilder
359 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
360 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
361 genResize' (Left res) f [arg] = do {
362 ; let { ty = Var.varType res
363 ; (tycon, args) = Type.splitTyConApp ty
364 ; name = Name.getOccString (TyCon.tyConName tycon)
366 ; len <- case name of
367 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
368 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
369 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
370 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
372 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
374 -- FIXME: I'm calling genLitArgs which is very specific function,
375 -- which needs to be fixed as well
376 genFromInteger :: BuiltinBuilder
377 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
378 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
379 genFromInteger' (Left res) f lits = do {
380 ; let { ty = Var.varType res
381 ; (tycon, args) = Type.splitTyConApp ty
382 ; name = Name.getOccString (TyCon.tyConName tycon)
385 "RangedWord" -> return $ AST.PrimLit (show (last lits))
387 ; len <- case name of
388 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
389 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
390 "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
391 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
392 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
393 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
397 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
399 genSizedInt :: BuiltinBuilder
400 genSizedInt = genFromInteger
403 -- | Generate a Builder for the builtin datacon TFVec
404 genTFVec :: BuiltinBuilder
405 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
406 -- Generate Assignments for all the binders
407 ; letAssigns <- mapM genBinderAssign letBinders
408 -- Generate assignments for the result (which might be another let binding)
409 ; (resBinders,resAssignments) <- genResAssign letRes
410 -- Get all the Assigned binders
411 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
412 -- Make signal names for all the assigned binders
413 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
414 -- Assign all the signals to the resulting vector
415 ; let { vecsigns = mkAggregateSignal sigs
416 ; vecassign = mkUncondAssign (Left res) vecsigns
418 -- Generate all the signal declaration for the assigned binders
419 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
420 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
421 -- Setup the VHDL Block
422 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
423 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
425 -- Return the block statement coressponding to the TFVec literal
426 ; return $ [AST.CSBSm block]
429 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
430 -- For now we only translate applications
431 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
432 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
433 let valargs = get_val_args (Var.varType f) args
434 apps <- genApplication (Left bndr) f (map Left valargs)
435 return (Just bndr, apps)
436 genBinderAssign _ = return (Nothing,[])
437 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
438 genResAssign app@(CoreSyn.App _ letexpr) = do
440 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
441 letapps <- mapM genBinderAssign letbndrs
442 let bndrs = Maybe.catMaybes (map fst letapps)
443 let app = (map snd letapps)
444 (vars, apps) <- genResAssign letres
445 return ((bndrs ++ vars),((concat app) ++ apps))
446 otherwise -> return ([],[])
447 genResAssign _ = return ([],[])
449 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
450 ; let { elems = reduceCoreListToHsList app
451 -- Make signal names for all the binders
452 ; binders = map (\expr -> case expr of
454 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
455 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
457 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
458 -- Assign all the signals to the resulting vector
459 ; let { vecsigns = mkAggregateSignal sigs
460 ; vecassign = mkUncondAssign (Left res) vecsigns
461 -- Setup the VHDL Block
462 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
463 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
465 -- Return the block statement coressponding to the TFVec literal
466 ; return $ [AST.CSBSm block]
469 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
471 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
473 -- | Generate a generate statement for the builtin function "map"
474 genMap :: BuiltinBuilder
475 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
476 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
477 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
478 -- we must index it (which we couldn't if it was a VHDL Expr, since only
479 -- VHDLNames can be indexed).
480 -- Setup the generate scheme
481 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
482 -- TODO: Use something better than varToString
483 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
484 ; n_id = mkVHDLBasicId "n"
485 ; n_expr = idToVHDLExpr n_id
486 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
487 ; genScheme = AST.ForGn n_id range
488 -- Create the content of the generate statement: Applying the mapped_f to
489 -- each of the elements in arg, storing to each element in res
490 ; resname = mkIndexedName (varToVHDLName res) n_expr
491 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
492 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
493 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
495 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
496 -- Return the generate statement
497 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
500 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
502 genZipWith :: BuiltinBuilder
503 genZipWith = genVarArgs genZipWith'
504 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
505 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
506 -- Setup the generate scheme
507 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
508 -- TODO: Use something better than varToString
509 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
510 ; n_id = mkVHDLBasicId "n"
511 ; n_expr = idToVHDLExpr n_id
512 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
513 ; genScheme = AST.ForGn n_id range
514 -- Create the content of the generate statement: Applying the zipped_f to
515 -- each of the elements in arg1 and arg2, storing to each element in res
516 ; resname = mkIndexedName (varToVHDLName res) n_expr
517 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
518 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
520 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
521 -- Return the generate functions
522 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
525 genFoldl :: BuiltinBuilder
526 genFoldl = genFold True
528 genFoldr :: BuiltinBuilder
529 genFoldr = genFold False
531 genFold :: Bool -> BuiltinBuilder
532 genFold left = genVarArgs (genFold' left)
534 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
535 genFold' left res f args@[folded_f , start ,vec]= do
536 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
537 genFold'' len left res f args
539 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
540 -- Special case for an empty input vector, just assign start to res
541 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
542 arg <- MonadState.lift tsType $ varToVHDLExpr start
543 return ([mkUncondAssign (Left res) arg], [])
545 genFold'' len left (Left res) f [folded_f, start, vec] = do
547 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
548 -- An expression for len-1
549 let len_min_expr = (AST.PrimLit $ show (len-1))
550 -- evec is (TFVec n), so it still needs an element type
551 let (nvec, _) = Type.splitAppTy (Var.varType vec)
552 -- Put the type of the start value in nvec, this will be the type of our
554 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
555 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
556 -- TODO: Handle Nothing
557 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
558 -- Setup the generate scheme
559 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
560 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
561 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
562 else AST.DownRange len_min_expr (AST.PrimLit "0")
563 let gen_scheme = AST.ForGn n_id gen_range
564 -- Make the intermediate vector
565 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
566 -- Create the generate statement
567 cells' <- sequence [genFirstCell, genOtherCell]
568 let (cells, useds) = unzip cells'
569 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
570 -- Assign tmp[len-1] or tmp[0] to res
571 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
572 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
573 (mkIndexedName tmp_name (AST.PrimLit "0")))
574 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
575 return ([AST.CSBSm block], concat useds)
577 -- An id for the counter
578 n_id = mkVHDLBasicId "n"
579 n_cur = idToVHDLExpr n_id
580 -- An expression for previous n
581 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
582 else (n_cur AST.:+: (AST.PrimLit "1"))
583 -- An id for the tmp result vector
584 tmp_id = mkVHDLBasicId "tmp"
585 tmp_name = AST.NSimple tmp_id
586 -- Generate parts of the fold
587 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
589 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
590 let cond_label = mkVHDLExtId "firstcell"
591 -- if n == 0 or n == len-1
592 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
593 else (AST.PrimLit $ show (len-1)))
594 -- Output to tmp[current n]
595 let resname = mkIndexedName tmp_name n_cur
597 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
598 -- Input from vec[current n]
599 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
600 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
601 [Right argexpr1, Right argexpr2]
603 [Right argexpr2, Right argexpr1]
605 -- Return the conditional generate part
606 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
609 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
610 let cond_label = mkVHDLExtId "othercell"
611 -- if n > 0 or n < len-1
612 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
613 else (AST.PrimLit $ show (len-1)))
614 -- Output to tmp[current n]
615 let resname = mkIndexedName tmp_name n_cur
616 -- Input from tmp[previous n]
617 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
618 -- Input from vec[current n]
619 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
620 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
621 [Right argexpr1, Right argexpr2]
623 [Right argexpr2, Right argexpr1]
625 -- Return the conditional generate part
626 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
628 -- | Generate a generate statement for the builtin function "zip"
629 genZip :: BuiltinBuilder
630 genZip = genNoInsts $ genVarArgs genZip'
631 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
632 genZip' (Left res) f args@[arg1, arg2] = do {
633 -- Setup the generate scheme
634 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
635 -- TODO: Use something better than varToString
636 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
637 ; n_id = mkVHDLBasicId "n"
638 ; n_expr = idToVHDLExpr n_id
639 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
640 ; genScheme = AST.ForGn n_id range
641 ; resname' = mkIndexedName (varToVHDLName res) n_expr
642 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
643 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
645 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
646 ; let { resnameA = mkSelectedName resname' (labels!!0)
647 ; resnameB = mkSelectedName resname' (labels!!1)
648 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
649 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
651 -- Return the generate functions
652 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
655 -- | Generate a generate statement for the builtin function "fst"
656 genFst :: BuiltinBuilder
657 genFst = genNoInsts $ genVarArgs genFst'
658 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
659 genFst' (Left res) f args@[arg] = do {
660 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
661 ; let { argexpr' = varToVHDLName arg
662 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
663 ; assign = mkUncondAssign (Left res) argexprA
665 -- Return the generate functions
669 -- | Generate a generate statement for the builtin function "snd"
670 genSnd :: BuiltinBuilder
671 genSnd = genNoInsts $ genVarArgs genSnd'
672 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
673 genSnd' (Left res) f args@[arg] = do {
674 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
675 ; let { argexpr' = varToVHDLName arg
676 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
677 ; assign = mkUncondAssign (Left res) argexprB
679 -- Return the generate functions
683 -- | Generate a generate statement for the builtin function "unzip"
684 genUnzip :: BuiltinBuilder
685 genUnzip = genNoInsts $ genVarArgs genUnzip'
686 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
687 genUnzip' (Left res) f args@[arg] = do {
688 -- Setup the generate scheme
689 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
690 -- TODO: Use something better than varToString
691 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
692 ; n_id = mkVHDLBasicId "n"
693 ; n_expr = idToVHDLExpr n_id
694 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
695 ; genScheme = AST.ForGn n_id range
696 ; resname' = varToVHDLName res
697 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
699 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
700 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
701 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
702 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
703 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
704 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
705 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
706 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
708 -- Return the generate functions
709 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
712 genCopy :: BuiltinBuilder
713 genCopy = genNoInsts $ genVarArgs genCopy'
714 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
715 genCopy' (Left res) f args@[arg] =
717 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
718 (AST.PrimName $ (varToVHDLName arg))]
719 out_assign = mkUncondAssign (Left res) resExpr
723 genConcat :: BuiltinBuilder
724 genConcat = genNoInsts $ genVarArgs genConcat'
725 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
726 genConcat' (Left res) f args@[arg] = do {
727 -- Setup the generate scheme
728 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
729 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
730 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
731 -- TODO: Use something better than varToString
732 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
733 ; n_id = mkVHDLBasicId "n"
734 ; n_expr = idToVHDLExpr n_id
735 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
736 ; genScheme = AST.ForGn n_id range
737 -- Create the content of the generate statement: Applying the mapped_f to
738 -- each of the elements in arg, storing to each element in res
739 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
740 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
741 ; resname = vecSlice fromRange toRange
742 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
743 ; out_assign = mkUncondAssign (Right resname) argexpr
745 -- Return the generate statement
746 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
749 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
750 (AST.ToRange init last))
752 genIteraten :: BuiltinBuilder
753 genIteraten dst f args = genIterate dst f (tail args)
755 genIterate :: BuiltinBuilder
756 genIterate = genIterateOrGenerate True
758 genGeneraten :: BuiltinBuilder
759 genGeneraten dst f args = genGenerate dst f (tail args)
761 genGenerate :: BuiltinBuilder
762 genGenerate = genIterateOrGenerate False
764 genIterateOrGenerate :: Bool -> BuiltinBuilder
765 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
767 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
768 genIterateOrGenerate' iter (Left res) f args = do
769 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
770 genIterateOrGenerate'' len iter (Left res) f args
772 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
773 -- Special case for an empty input vector, just assign start to res
774 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
776 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
778 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
779 -- An expression for len-1
780 let len_min_expr = (AST.PrimLit $ show (len-1))
781 -- -- evec is (TFVec n), so it still needs an element type
782 -- let (nvec, _) = splitAppTy (Var.varType vec)
783 -- -- Put the type of the start value in nvec, this will be the type of our
784 -- -- temporary vector
785 let tmp_ty = Var.varType res
786 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
787 -- TODO: Handle Nothing
788 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
789 -- Setup the generate scheme
790 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
791 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
792 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
793 let gen_scheme = AST.ForGn n_id gen_range
794 -- Make the intermediate vector
795 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
796 -- Create the generate statement
797 cells' <- sequence [genFirstCell, genOtherCell]
798 let (cells, useds) = unzip cells'
799 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
800 -- Assign tmp[len-1] or tmp[0] to res
801 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
802 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
803 return ([AST.CSBSm block], concat useds)
805 -- An id for the counter
806 n_id = mkVHDLBasicId "n"
807 n_cur = idToVHDLExpr n_id
808 -- An expression for previous n
809 n_prev = n_cur AST.:-: (AST.PrimLit "1")
810 -- An id for the tmp result vector
811 tmp_id = mkVHDLBasicId "tmp"
812 tmp_name = AST.NSimple tmp_id
813 -- Generate parts of the fold
814 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
816 let cond_label = mkVHDLExtId "firstcell"
817 -- if n == 0 or n == len-1
818 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
819 -- Output to tmp[current n]
820 let resname = mkIndexedName tmp_name n_cur
822 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
823 let startassign = mkUncondAssign (Right resname) argexpr
824 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
825 -- Return the conditional generate part
826 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
834 let cond_label = mkVHDLExtId "othercell"
835 -- if n > 0 or n < len-1
836 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
837 -- Output to tmp[current n]
838 let resname = mkIndexedName tmp_name n_cur
839 -- Input from tmp[previous n]
840 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
841 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
842 -- Return the conditional generate part
843 return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
845 genBlockRAM :: BuiltinBuilder
846 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
848 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
849 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
851 let (tup,data_out) = Type.splitAppTy (Var.varType res)
852 let (tup',ramvec) = Type.splitAppTy tup
853 let Just realram = Type.coreView ramvec
854 let Just (tycon, types) = Type.splitTyConApp_maybe realram
855 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdl_ty "wtf" (head types)
856 -- Make the intermediate vector
857 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
858 -- Get the data_out name
859 reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
860 let resname' = varToVHDLName res
861 let resname = mkSelectedName resname' (reslabels!!0)
862 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr
863 let assign = mkUncondAssign (Right resname) argexpr
864 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
865 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
866 return [AST.CSBSm block]
868 ram_id = mkVHDLBasicId "ram"
869 mkUpdateProcSm :: AST.ConcSm
870 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
872 proclabel = mkVHDLBasicId "updateRAM"
873 rising_edge = mkVHDLBasicId "rising_edge"
874 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr
875 wform = AST.Wform [AST.WformElem data_in Nothing]
876 ramassign = AST.SigAssign ramloc wform
877 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
878 statement = AST.IfSm (AST.And rising_edge_clk (wrenable AST.:=: AST.PrimLit "'1'")) [ramassign] [] Nothing
880 -----------------------------------------------------------------------------
881 -- Function to generate VHDL for applications
882 -----------------------------------------------------------------------------
884 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
885 -> CoreSyn.CoreBndr -- ^ The function to apply
886 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
887 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
888 -- ^ The corresponding VHDL concurrent statements and entities
890 genApplication dst f args = do
891 case Var.isGlobalId f of
893 top <- isTopLevelBinder f
896 -- Local binder that references a top level binding. Generate a
897 -- component instantiation.
898 signature <- getEntity f
899 args' <- argsToVHDLExprs args
900 let entity_id = ent_id signature
901 -- TODO: Using show here isn't really pretty, but we'll need some
902 -- unique-ish value...
903 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
904 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
905 return ([mkComponentInst label entity_id portmaps], [f])
907 -- Not a top level binder, so this must be a local variable reference.
908 -- It should have a representable type (and thus, no arguments) and a
909 -- signal should be generated for it. Just generate an unconditional
911 f' <- MonadState.lift tsType $ varToVHDLExpr f
912 return $ ([mkUncondAssign dst f'], [])
914 case Var.idDetails f of
915 IdInfo.DataConWorkId dc -> case dst of
916 -- It's a datacon. Create a record from its arguments.
918 -- We have the bndr, so we can get at the type
919 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
920 args' <- argsToVHDLExprs args
921 return $ (zipWith mkassign labels $ args', [])
923 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
925 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
926 mkUncondAssign (Right sel_name) arg
927 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
928 IdInfo.DataConWrapId dc -> case dst of
929 -- It's a datacon. Create a record from its arguments.
931 case (Map.lookup (varToString f) globalNameTable) of
932 Just (arg_count, builder) ->
933 if length args == arg_count then
936 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
937 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
938 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
939 IdInfo.VanillaId -> do
940 -- It's a global value imported from elsewhere. These can be builtin
941 -- functions. Look up the function name in the name table and execute
942 -- the associated builder if there is any and the argument count matches
943 -- (this should always be the case if it typechecks, but just to be
945 case (Map.lookup (varToString f) globalNameTable) of
946 Just (arg_count, builder) ->
947 if length args == arg_count then
950 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
952 top <- isTopLevelBinder f
955 -- Local binder that references a top level binding. Generate a
956 -- component instantiation.
957 signature <- getEntity f
958 args' <- argsToVHDLExprs args
959 let entity_id = ent_id signature
960 -- TODO: Using show here isn't really pretty, but we'll need some
961 -- unique-ish value...
962 let label = "comp_ins_" ++ (either show prettyShow) dst
963 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
964 return ([mkComponentInst label entity_id portmaps], [f])
966 -- Not a top level binder, so this must be a local variable reference.
967 -- It should have a representable type (and thus, no arguments) and a
968 -- signal should be generated for it. Just generate an unconditional
970 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
971 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
972 -- return $ ([mkUncondAssign dst f'], [])
973 error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
974 IdInfo.ClassOpId cls -> do
975 -- FIXME: Not looking for what instance this class op is called for
976 -- Is quite stupid of course.
977 case (Map.lookup (varToString f) globalNameTable) of
978 Just (arg_count, builder) ->
979 if length args == arg_count then
982 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
983 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
984 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
986 -----------------------------------------------------------------------------
987 -- Functions to generate functions dealing with vectors.
988 -----------------------------------------------------------------------------
990 -- Returns the VHDLId of the vector function with the given name for the given
991 -- element type. Generates -- this function if needed.
992 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
993 vectorFunId el_ty fname = do
994 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
995 -- TODO: Handle the Nothing case?
996 Just elemTM <- vhdl_ty error_msg el_ty
997 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
998 -- the VHDLState or something.
999 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1000 typefuns <- getA tsTypeFuns
1001 case Map.lookup (OrdType el_ty, fname) typefuns of
1002 -- Function already generated, just return it
1003 Just (id, _) -> return id
1004 -- Function not generated yet, generate it
1006 let functions = genUnconsVectorFuns elemTM vectorTM
1007 case lookup fname functions of
1009 modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
1010 mapM_ (vectorFunId el_ty) (snd body)
1012 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1014 function_id = mkVHDLExtId fname
1016 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1017 -> AST.TypeMark -- ^ type of the vector
1018 -> [(String, (AST.SubProgBody, [String]))]
1019 genUnconsVectorFuns elemTM vectorTM =
1020 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1021 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1022 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1023 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1024 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1025 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1026 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1027 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1028 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1029 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1030 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1031 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1032 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1033 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1034 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1035 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1036 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1037 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1038 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1039 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1040 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1043 ixPar = AST.unsafeVHDLBasicId "ix"
1044 vecPar = AST.unsafeVHDLBasicId "vec"
1045 vec1Par = AST.unsafeVHDLBasicId "vec1"
1046 vec2Par = AST.unsafeVHDLBasicId "vec2"
1047 nPar = AST.unsafeVHDLBasicId "n"
1048 leftPar = AST.unsafeVHDLBasicId "nLeft"
1049 rightPar = AST.unsafeVHDLBasicId "nRight"
1050 iId = AST.unsafeVHDLBasicId "i"
1052 aPar = AST.unsafeVHDLBasicId "a"
1053 fPar = AST.unsafeVHDLBasicId "f"
1054 sPar = AST.unsafeVHDLBasicId "s"
1055 resId = AST.unsafeVHDLBasicId "res"
1056 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1057 AST.IfaceVarDec ixPar naturalTM] elemTM
1058 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1059 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
1060 AST.NSimple ixPar]))
1061 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1062 , AST.IfaceVarDec iPar naturalTM
1063 , AST.IfaceVarDec aPar elemTM
1065 -- variable res : fsvec_x (0 to vec'length-1);
1068 (AST.SubtypeIn vectorTM
1069 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1070 [AST.ToRange (AST.PrimLit "0")
1071 (AST.PrimName (AST.NAttribute $
1072 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1073 (AST.PrimLit "1")) ]))
1075 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1076 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1077 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName $ AST.NSimple iPar]) AST.:= AST.PrimName (AST.NSimple aPar)
1078 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1079 vecSlice init last = AST.PrimName (AST.NSlice
1081 (AST.NSimple vecPar)
1082 (AST.ToRange init last)))
1083 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1084 -- return vec(vec'length-1);
1085 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1086 (AST.NSimple vecPar)
1087 [AST.PrimName (AST.NAttribute $
1088 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1089 AST.:-: AST.PrimLit "1"])))
1090 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1091 -- variable res : fsvec_x (0 to vec'length-2);
1094 (AST.SubtypeIn vectorTM
1095 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1096 [AST.ToRange (AST.PrimLit "0")
1097 (AST.PrimName (AST.NAttribute $
1098 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1099 (AST.PrimLit "2")) ]))
1101 -- resAST.:= vec(0 to vec'length-2)
1102 initExpr = AST.NSimple resId AST.:= (vecSlice
1104 (AST.PrimName (AST.NAttribute $
1105 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1106 AST.:-: AST.PrimLit "2"))
1107 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1108 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1109 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1110 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1111 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1113 (Just $ AST.Else [minimumExprRet])
1114 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1115 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1116 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1117 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1118 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1119 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1120 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1121 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1124 (AST.SubtypeIn vectorTM
1125 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1126 [AST.ToRange (AST.PrimLit "0")
1128 (AST.PrimLit "1")) ]))
1130 -- res AST.:= vec(0 to n-1)
1131 takeExpr = AST.NSimple resId AST.:=
1132 (vecSlice (AST.PrimLit "0")
1133 (minLength AST.:-: AST.PrimLit "1"))
1134 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1135 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1136 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1137 -- variable res : fsvec_x (0 to vec'length-n-1);
1140 (AST.SubtypeIn vectorTM
1141 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1142 [AST.ToRange (AST.PrimLit "0")
1143 (AST.PrimName (AST.NAttribute $
1144 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1145 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1147 -- res AST.:= vec(n to vec'length-1)
1148 dropExpr = AST.NSimple resId AST.:= (vecSlice
1149 (AST.PrimName $ AST.NSimple nPar)
1150 (AST.PrimName (AST.NAttribute $
1151 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1152 AST.:-: AST.PrimLit "1"))
1153 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1154 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1155 AST.IfaceVarDec vecPar vectorTM] vectorTM
1156 -- variable res : fsvec_x (0 to vec'length);
1159 (AST.SubtypeIn vectorTM
1160 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1161 [AST.ToRange (AST.PrimLit "0")
1162 (AST.PrimName (AST.NAttribute $
1163 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1165 plusgtExpr = AST.NSimple resId AST.:=
1166 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1167 (AST.PrimName $ AST.NSimple vecPar))
1168 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1169 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1172 (AST.SubtypeIn vectorTM
1173 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1174 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1176 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1177 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1179 -- variable res : fsvec_x (0 to 0) := (others => a);
1182 (AST.SubtypeIn vectorTM
1183 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1184 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1185 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1186 (AST.PrimName $ AST.NSimple aPar)])
1187 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1188 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1189 AST.IfaceVarDec aPar elemTM ] vectorTM
1190 -- variable res : fsvec_x (0 to n-1) := (others => a);
1193 (AST.SubtypeIn vectorTM
1194 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1195 [AST.ToRange (AST.PrimLit "0")
1196 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1197 (AST.PrimLit "1")) ]))
1198 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1199 (AST.PrimName $ AST.NSimple aPar)])
1201 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1202 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1203 AST.IfaceVarDec sPar naturalTM,
1204 AST.IfaceVarDec nPar naturalTM,
1205 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1206 -- variable res : fsvec_x (0 to n-1);
1209 (AST.SubtypeIn vectorTM
1210 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1211 [AST.ToRange (AST.PrimLit "0")
1212 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1213 (AST.PrimLit "1")) ])
1216 -- for i res'range loop
1217 -- res(i) := vec(f+i*s);
1219 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1220 -- res(i) := vec(f+i*s);
1221 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1222 (AST.PrimName (AST.NSimple iId) AST.:*:
1223 AST.PrimName (AST.NSimple sPar)) in
1224 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1225 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1227 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1228 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1229 AST.IfaceVarDec aPar elemTM] vectorTM
1230 -- variable res : fsvec_x (0 to vec'length);
1233 (AST.SubtypeIn vectorTM
1234 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1235 [AST.ToRange (AST.PrimLit "0")
1236 (AST.PrimName (AST.NAttribute $
1237 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1239 ltplusExpr = AST.NSimple resId AST.:=
1240 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1241 (AST.PrimName $ AST.NSimple aPar))
1242 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1243 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1244 AST.IfaceVarDec vec2Par vectorTM]
1246 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1249 (AST.SubtypeIn vectorTM
1250 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1251 [AST.ToRange (AST.PrimLit "0")
1252 (AST.PrimName (AST.NAttribute $
1253 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1254 AST.PrimName (AST.NAttribute $
1255 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1258 plusplusExpr = AST.NSimple resId AST.:=
1259 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1260 (AST.PrimName $ AST.NSimple vec2Par))
1261 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1262 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1263 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1264 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1265 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1266 AST.IfaceVarDec aPar elemTM ] vectorTM
1267 -- variable res : fsvec_x (0 to vec'length-1);
1270 (AST.SubtypeIn vectorTM
1271 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1272 [AST.ToRange (AST.PrimLit "0")
1273 (AST.PrimName (AST.NAttribute $
1274 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1275 (AST.PrimLit "1")) ]))
1277 -- res := a & init(vec)
1278 shiftlExpr = AST.NSimple resId AST.:=
1279 (AST.PrimName (AST.NSimple aPar) AST.:&:
1280 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1281 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1282 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1283 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1284 AST.IfaceVarDec aPar elemTM ] vectorTM
1285 -- variable res : fsvec_x (0 to vec'length-1);
1288 (AST.SubtypeIn vectorTM
1289 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1290 [AST.ToRange (AST.PrimLit "0")
1291 (AST.PrimName (AST.NAttribute $
1292 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1293 (AST.PrimLit "1")) ]))
1295 -- res := tail(vec) & a
1296 shiftrExpr = AST.NSimple resId AST.:=
1297 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1298 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1299 (AST.PrimName (AST.NSimple aPar)))
1301 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1302 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1303 -- return vec'length = 0
1304 nullExpr = AST.ReturnSm (Just $
1305 AST.PrimName (AST.NAttribute $
1306 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1308 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1309 -- variable res : fsvec_x (0 to vec'length-1);
1312 (AST.SubtypeIn vectorTM
1313 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1314 [AST.ToRange (AST.PrimLit "0")
1315 (AST.PrimName (AST.NAttribute $
1316 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1317 (AST.PrimLit "1")) ]))
1319 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1320 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1321 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1322 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1324 (Just $ AST.Else [rotlExprRet])
1326 AST.NSimple resId AST.:=
1327 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1328 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1329 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1330 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1331 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1332 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1333 -- variable res : fsvec_x (0 to vec'length-1);
1336 (AST.SubtypeIn vectorTM
1337 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1338 [AST.ToRange (AST.PrimLit "0")
1339 (AST.PrimName (AST.NAttribute $
1340 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1341 (AST.PrimLit "1")) ]))
1343 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1344 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1345 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1346 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1348 (Just $ AST.Else [rotrExprRet])
1350 AST.NSimple resId AST.:=
1351 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1352 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1353 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1354 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1355 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1356 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1359 (AST.SubtypeIn vectorTM
1360 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1361 [AST.ToRange (AST.PrimLit "0")
1362 (AST.PrimName (AST.NAttribute $
1363 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1364 (AST.PrimLit "1")) ]))
1366 -- for i in 0 to res'range loop
1367 -- res(vec'length-i-1) := vec(i);
1370 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1371 -- res(vec'length-i-1) := vec(i);
1372 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1373 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1374 [AST.PrimName $ AST.NSimple iId]))
1375 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1376 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1377 AST.PrimName (AST.NSimple iId) AST.:-:
1380 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1383 -----------------------------------------------------------------------------
1384 -- A table of builtin functions
1385 -----------------------------------------------------------------------------
1387 -- A function that generates VHDL for a builtin function
1388 type BuiltinBuilder =
1389 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1390 -> CoreSyn.CoreBndr -- ^ The function called
1391 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1392 -- dictionary arguments).
1393 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1394 -- ^ The corresponding VHDL concurrent statements and entities
1397 -- A map of a builtin function to VHDL function builder
1398 type NameTable = Map.Map String (Int, BuiltinBuilder )
1400 -- | The builtin functions we support. Maps a name to an argument count and a
1401 -- builder function.
1402 globalNameTable :: NameTable
1403 globalNameTable = Map.fromList
1404 [ (exId , (2, genFCall True ) )
1405 , (replaceId , (3, genFCall False ) )
1406 , (headId , (1, genFCall True ) )
1407 , (lastId , (1, genFCall True ) )
1408 , (tailId , (1, genFCall False ) )
1409 , (initId , (1, genFCall False ) )
1410 , (takeId , (2, genFCall False ) )
1411 , (dropId , (2, genFCall False ) )
1412 , (selId , (4, genFCall False ) )
1413 , (plusgtId , (2, genFCall False ) )
1414 , (ltplusId , (2, genFCall False ) )
1415 , (plusplusId , (2, genFCall False ) )
1416 , (mapId , (2, genMap ) )
1417 , (zipWithId , (3, genZipWith ) )
1418 , (foldlId , (3, genFoldl ) )
1419 , (foldrId , (3, genFoldr ) )
1420 , (zipId , (2, genZip ) )
1421 , (unzipId , (1, genUnzip ) )
1422 , (shiftlId , (2, genFCall False ) )
1423 , (shiftrId , (2, genFCall False ) )
1424 , (rotlId , (1, genFCall False ) )
1425 , (rotrId , (1, genFCall False ) )
1426 , (concatId , (1, genConcat ) )
1427 , (reverseId , (1, genFCall False ) )
1428 , (iteratenId , (3, genIteraten ) )
1429 , (iterateId , (2, genIterate ) )
1430 , (generatenId , (3, genGeneraten ) )
1431 , (generateId , (2, genGenerate ) )
1432 , (emptyId , (0, genFCall False ) )
1433 , (singletonId , (1, genFCall False ) )
1434 , (copynId , (2, genFCall False ) )
1435 , (copyId , (1, genCopy ) )
1436 , (lengthTId , (1, genFCall False ) )
1437 , (nullId , (1, genFCall False ) )
1438 , (hwxorId , (2, genOperator2 AST.Xor ) )
1439 , (hwandId , (2, genOperator2 AST.And ) )
1440 , (hworId , (2, genOperator2 AST.Or ) )
1441 , (hwnotId , (1, genOperator1 AST.Not ) )
1442 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1443 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1444 , (boolOrId , (2, genOperator2 AST.Or ) )
1445 , (boolAndId , (2, genOperator2 AST.And ) )
1446 , (plusId , (2, genOperator2 (AST.:+:) ) )
1447 , (timesId , (2, genOperator2 (AST.:*:) ) )
1448 , (negateId , (1, genNegation ) )
1449 , (minusId , (2, genOperator2 (AST.:-:) ) )
1450 , (fromSizedWordId , (1, genFromSizedWord ) )
1451 , (fromIntegerId , (1, genFromInteger ) )
1452 , (resizeId , (1, genResize ) )
1453 , (sizedIntId , (1, genSizedInt ) )
1454 , (smallIntegerId , (1, genFromInteger ) )
1455 , (fstId , (1, genFst ) )
1456 , (sndId , (1, genSnd ) )
1457 , (blockRAMId , (5, genBlockRAM ) )
1458 --, (tfvecId , (1, genTFVec ) )
1459 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))