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)
843 -----------------------------------------------------------------------------
844 -- Function to generate VHDL for applications
845 -----------------------------------------------------------------------------
847 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
848 -> CoreSyn.CoreBndr -- ^ The function to apply
849 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
850 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
851 -- ^ The corresponding VHDL concurrent statements and entities
853 genApplication dst f args = do
854 case Var.isGlobalId f of
856 top <- isTopLevelBinder f
859 -- Local binder that references a top level binding. Generate a
860 -- component instantiation.
861 signature <- getEntity f
862 args' <- argsToVHDLExprs args
863 let entity_id = ent_id signature
864 -- TODO: Using show here isn't really pretty, but we'll need some
865 -- unique-ish value...
866 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
867 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
868 return ([mkComponentInst label entity_id portmaps], [f])
870 -- Not a top level binder, so this must be a local variable reference.
871 -- It should have a representable type (and thus, no arguments) and a
872 -- signal should be generated for it. Just generate an unconditional
874 f' <- MonadState.lift tsType $ varToVHDLExpr f
875 return $ ([mkUncondAssign dst f'], [])
877 case Var.idDetails f of
878 IdInfo.DataConWorkId dc -> case dst of
879 -- It's a datacon. Create a record from its arguments.
881 -- We have the bndr, so we can get at the type
882 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
883 args' <- argsToVHDLExprs args
884 return $ (zipWith mkassign labels $ args', [])
886 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
888 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
889 mkUncondAssign (Right sel_name) arg
890 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
891 IdInfo.DataConWrapId dc -> case dst of
892 -- It's a datacon. Create a record from its arguments.
894 case (Map.lookup (varToString f) globalNameTable) of
895 Just (arg_count, builder) ->
896 if length args == arg_count then
899 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
900 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
901 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
902 IdInfo.VanillaId -> do
903 -- It's a global value imported from elsewhere. These can be builtin
904 -- functions. Look up the function name in the name table and execute
905 -- the associated builder if there is any and the argument count matches
906 -- (this should always be the case if it typechecks, but just to be
908 case (Map.lookup (varToString f) globalNameTable) of
909 Just (arg_count, builder) ->
910 if length args == arg_count then
913 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
915 top <- isTopLevelBinder f
918 -- Local binder that references a top level binding. Generate a
919 -- component instantiation.
920 signature <- getEntity f
921 args' <- argsToVHDLExprs args
922 let entity_id = ent_id signature
923 -- TODO: Using show here isn't really pretty, but we'll need some
924 -- unique-ish value...
925 let label = "comp_ins_" ++ (either show prettyShow) dst
926 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
927 return ([mkComponentInst label entity_id portmaps], [f])
929 -- Not a top level binder, so this must be a local variable reference.
930 -- It should have a representable type (and thus, no arguments) and a
931 -- signal should be generated for it. Just generate an unconditional
933 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
934 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
935 -- return $ ([mkUncondAssign dst f'], [])
936 error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
937 IdInfo.ClassOpId cls -> do
938 -- FIXME: Not looking for what instance this class op is called for
939 -- Is quite stupid of course.
940 case (Map.lookup (varToString f) globalNameTable) of
941 Just (arg_count, builder) ->
942 if length args == arg_count then
945 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
946 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
947 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
949 -----------------------------------------------------------------------------
950 -- Functions to generate functions dealing with vectors.
951 -----------------------------------------------------------------------------
953 -- Returns the VHDLId of the vector function with the given name for the given
954 -- element type. Generates -- this function if needed.
955 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
956 vectorFunId el_ty fname = do
957 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
958 -- TODO: Handle the Nothing case?
959 Just elemTM <- vhdl_ty error_msg el_ty
960 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
961 -- the VHDLState or something.
962 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
963 typefuns <- getA tsTypeFuns
964 case Map.lookup (OrdType el_ty, fname) typefuns of
965 -- Function already generated, just return it
966 Just (id, _) -> return id
967 -- Function not generated yet, generate it
969 let functions = genUnconsVectorFuns elemTM vectorTM
970 case lookup fname functions of
972 modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
973 mapM_ (vectorFunId el_ty) (snd body)
975 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
977 function_id = mkVHDLExtId fname
979 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
980 -> AST.TypeMark -- ^ type of the vector
981 -> [(String, (AST.SubProgBody, [String]))]
982 genUnconsVectorFuns elemTM vectorTM =
983 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
984 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
985 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
986 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
987 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
988 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
989 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
990 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
991 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
992 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
993 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
994 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
995 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
996 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
997 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
998 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
999 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1000 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1001 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1002 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1003 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1006 ixPar = AST.unsafeVHDLBasicId "ix"
1007 vecPar = AST.unsafeVHDLBasicId "vec"
1008 vec1Par = AST.unsafeVHDLBasicId "vec1"
1009 vec2Par = AST.unsafeVHDLBasicId "vec2"
1010 nPar = AST.unsafeVHDLBasicId "n"
1011 leftPar = AST.unsafeVHDLBasicId "nLeft"
1012 rightPar = AST.unsafeVHDLBasicId "nRight"
1013 iId = AST.unsafeVHDLBasicId "i"
1015 aPar = AST.unsafeVHDLBasicId "a"
1016 fPar = AST.unsafeVHDLBasicId "f"
1017 sPar = AST.unsafeVHDLBasicId "s"
1018 resId = AST.unsafeVHDLBasicId "res"
1019 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1020 AST.IfaceVarDec ixPar naturalTM] elemTM
1021 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1022 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
1023 AST.NSimple ixPar]))
1024 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1025 , AST.IfaceVarDec iPar naturalTM
1026 , AST.IfaceVarDec aPar elemTM
1028 -- variable res : fsvec_x (0 to vec'length-1);
1031 (AST.SubtypeIn vectorTM
1032 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1033 [AST.ToRange (AST.PrimLit "0")
1034 (AST.PrimName (AST.NAttribute $
1035 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1036 (AST.PrimLit "1")) ]))
1038 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1039 replaceExpr = AST.NSimple resId AST.:=
1040 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
1041 AST.PrimName (AST.NSimple aPar) AST.:&:
1042 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
1043 ((AST.PrimName (AST.NAttribute $
1044 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1045 AST.:-: AST.PrimLit "1"))
1046 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1047 vecSlice init last = AST.PrimName (AST.NSlice
1049 (AST.NSimple vecPar)
1050 (AST.ToRange init last)))
1051 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1052 -- return vec(vec'length-1);
1053 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1054 (AST.NSimple vecPar)
1055 [AST.PrimName (AST.NAttribute $
1056 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1057 AST.:-: AST.PrimLit "1"])))
1058 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1059 -- variable res : fsvec_x (0 to vec'length-2);
1062 (AST.SubtypeIn vectorTM
1063 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1064 [AST.ToRange (AST.PrimLit "0")
1065 (AST.PrimName (AST.NAttribute $
1066 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1067 (AST.PrimLit "2")) ]))
1069 -- resAST.:= vec(0 to vec'length-2)
1070 initExpr = AST.NSimple resId AST.:= (vecSlice
1072 (AST.PrimName (AST.NAttribute $
1073 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1074 AST.:-: AST.PrimLit "2"))
1075 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1076 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1077 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1078 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1079 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1081 (Just $ AST.Else [minimumExprRet])
1082 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1083 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1084 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1085 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1086 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1087 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1088 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1089 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1092 (AST.SubtypeIn vectorTM
1093 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1094 [AST.ToRange (AST.PrimLit "0")
1096 (AST.PrimLit "1")) ]))
1098 -- res AST.:= vec(0 to n-1)
1099 takeExpr = AST.NSimple resId AST.:=
1100 (vecSlice (AST.PrimLit "0")
1101 (minLength AST.:-: AST.PrimLit "1"))
1102 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1103 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1104 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1105 -- variable res : fsvec_x (0 to vec'length-n-1);
1108 (AST.SubtypeIn vectorTM
1109 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1110 [AST.ToRange (AST.PrimLit "0")
1111 (AST.PrimName (AST.NAttribute $
1112 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1113 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1115 -- res AST.:= vec(n to vec'length-1)
1116 dropExpr = AST.NSimple resId AST.:= (vecSlice
1117 (AST.PrimName $ AST.NSimple nPar)
1118 (AST.PrimName (AST.NAttribute $
1119 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1120 AST.:-: AST.PrimLit "1"))
1121 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1122 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1123 AST.IfaceVarDec vecPar vectorTM] vectorTM
1124 -- variable res : fsvec_x (0 to vec'length);
1127 (AST.SubtypeIn vectorTM
1128 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1129 [AST.ToRange (AST.PrimLit "0")
1130 (AST.PrimName (AST.NAttribute $
1131 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1133 plusgtExpr = AST.NSimple resId AST.:=
1134 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1135 (AST.PrimName $ AST.NSimple vecPar))
1136 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1137 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1140 (AST.SubtypeIn vectorTM
1141 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1142 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1144 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1145 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1147 -- variable res : fsvec_x (0 to 0) := (others => a);
1150 (AST.SubtypeIn vectorTM
1151 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1152 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1153 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1154 (AST.PrimName $ AST.NSimple aPar)])
1155 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1156 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1157 AST.IfaceVarDec aPar elemTM ] vectorTM
1158 -- variable res : fsvec_x (0 to n-1) := (others => a);
1161 (AST.SubtypeIn vectorTM
1162 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1163 [AST.ToRange (AST.PrimLit "0")
1164 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1165 (AST.PrimLit "1")) ]))
1166 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1167 (AST.PrimName $ AST.NSimple aPar)])
1169 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1170 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1171 AST.IfaceVarDec sPar naturalTM,
1172 AST.IfaceVarDec nPar naturalTM,
1173 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1174 -- variable res : fsvec_x (0 to n-1);
1177 (AST.SubtypeIn vectorTM
1178 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1179 [AST.ToRange (AST.PrimLit "0")
1180 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1181 (AST.PrimLit "1")) ])
1184 -- for i res'range loop
1185 -- res(i) := vec(f+i*s);
1187 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1188 -- res(i) := vec(f+i*s);
1189 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1190 (AST.PrimName (AST.NSimple iId) AST.:*:
1191 AST.PrimName (AST.NSimple sPar)) in
1192 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1193 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1195 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1196 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1197 AST.IfaceVarDec aPar elemTM] vectorTM
1198 -- variable res : fsvec_x (0 to vec'length);
1201 (AST.SubtypeIn vectorTM
1202 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1203 [AST.ToRange (AST.PrimLit "0")
1204 (AST.PrimName (AST.NAttribute $
1205 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1207 ltplusExpr = AST.NSimple resId AST.:=
1208 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1209 (AST.PrimName $ AST.NSimple aPar))
1210 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1211 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1212 AST.IfaceVarDec vec2Par vectorTM]
1214 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1217 (AST.SubtypeIn vectorTM
1218 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1219 [AST.ToRange (AST.PrimLit "0")
1220 (AST.PrimName (AST.NAttribute $
1221 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1222 AST.PrimName (AST.NAttribute $
1223 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1226 plusplusExpr = AST.NSimple resId AST.:=
1227 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1228 (AST.PrimName $ AST.NSimple vec2Par))
1229 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1230 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1231 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1232 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1233 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1234 AST.IfaceVarDec aPar elemTM ] vectorTM
1235 -- variable res : fsvec_x (0 to vec'length-1);
1238 (AST.SubtypeIn vectorTM
1239 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1240 [AST.ToRange (AST.PrimLit "0")
1241 (AST.PrimName (AST.NAttribute $
1242 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1243 (AST.PrimLit "1")) ]))
1245 -- res := a & init(vec)
1246 shiftlExpr = AST.NSimple resId AST.:=
1247 (AST.PrimName (AST.NSimple aPar) AST.:&:
1248 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1249 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1250 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1251 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1252 AST.IfaceVarDec aPar elemTM ] vectorTM
1253 -- variable res : fsvec_x (0 to vec'length-1);
1256 (AST.SubtypeIn vectorTM
1257 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1258 [AST.ToRange (AST.PrimLit "0")
1259 (AST.PrimName (AST.NAttribute $
1260 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1261 (AST.PrimLit "1")) ]))
1263 -- res := tail(vec) & a
1264 shiftrExpr = AST.NSimple resId AST.:=
1265 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1266 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1267 (AST.PrimName (AST.NSimple aPar)))
1269 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1270 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1271 -- return vec'length = 0
1272 nullExpr = AST.ReturnSm (Just $
1273 AST.PrimName (AST.NAttribute $
1274 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1276 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1277 -- variable res : fsvec_x (0 to vec'length-1);
1280 (AST.SubtypeIn vectorTM
1281 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1282 [AST.ToRange (AST.PrimLit "0")
1283 (AST.PrimName (AST.NAttribute $
1284 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1285 (AST.PrimLit "1")) ]))
1287 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1288 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1289 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1290 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1292 (Just $ AST.Else [rotlExprRet])
1294 AST.NSimple resId AST.:=
1295 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1296 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1297 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1298 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1299 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1300 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1301 -- variable res : fsvec_x (0 to vec'length-1);
1304 (AST.SubtypeIn vectorTM
1305 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1306 [AST.ToRange (AST.PrimLit "0")
1307 (AST.PrimName (AST.NAttribute $
1308 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1309 (AST.PrimLit "1")) ]))
1311 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1312 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1313 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1314 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1316 (Just $ AST.Else [rotrExprRet])
1318 AST.NSimple resId AST.:=
1319 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1320 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1321 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1322 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1323 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1324 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1327 (AST.SubtypeIn vectorTM
1328 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1329 [AST.ToRange (AST.PrimLit "0")
1330 (AST.PrimName (AST.NAttribute $
1331 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1332 (AST.PrimLit "1")) ]))
1334 -- for i in 0 to res'range loop
1335 -- res(vec'length-i-1) := vec(i);
1338 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1339 -- res(vec'length-i-1) := vec(i);
1340 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1341 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1342 [AST.PrimName $ AST.NSimple iId]))
1343 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1344 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1345 AST.PrimName (AST.NSimple iId) AST.:-:
1348 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1351 -----------------------------------------------------------------------------
1352 -- A table of builtin functions
1353 -----------------------------------------------------------------------------
1355 -- A function that generates VHDL for a builtin function
1356 type BuiltinBuilder =
1357 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1358 -> CoreSyn.CoreBndr -- ^ The function called
1359 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1360 -- dictionary arguments).
1361 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1362 -- ^ The corresponding VHDL concurrent statements and entities
1365 -- A map of a builtin function to VHDL function builder
1366 type NameTable = Map.Map String (Int, BuiltinBuilder )
1368 -- | The builtin functions we support. Maps a name to an argument count and a
1369 -- builder function.
1370 globalNameTable :: NameTable
1371 globalNameTable = Map.fromList
1372 [ (exId , (2, genFCall True ) )
1373 , (replaceId , (3, genFCall False ) )
1374 , (headId , (1, genFCall True ) )
1375 , (lastId , (1, genFCall True ) )
1376 , (tailId , (1, genFCall False ) )
1377 , (initId , (1, genFCall False ) )
1378 , (takeId , (2, genFCall False ) )
1379 , (dropId , (2, genFCall False ) )
1380 , (selId , (4, genFCall False ) )
1381 , (plusgtId , (2, genFCall False ) )
1382 , (ltplusId , (2, genFCall False ) )
1383 , (plusplusId , (2, genFCall False ) )
1384 , (mapId , (2, genMap ) )
1385 , (zipWithId , (3, genZipWith ) )
1386 , (foldlId , (3, genFoldl ) )
1387 , (foldrId , (3, genFoldr ) )
1388 , (zipId , (2, genZip ) )
1389 , (unzipId , (1, genUnzip ) )
1390 , (shiftlId , (2, genFCall False ) )
1391 , (shiftrId , (2, genFCall False ) )
1392 , (rotlId , (1, genFCall False ) )
1393 , (rotrId , (1, genFCall False ) )
1394 , (concatId , (1, genConcat ) )
1395 , (reverseId , (1, genFCall False ) )
1396 , (iteratenId , (3, genIteraten ) )
1397 , (iterateId , (2, genIterate ) )
1398 , (generatenId , (3, genGeneraten ) )
1399 , (generateId , (2, genGenerate ) )
1400 , (emptyId , (0, genFCall False ) )
1401 , (singletonId , (1, genFCall False ) )
1402 , (copynId , (2, genFCall False ) )
1403 , (copyId , (1, genCopy ) )
1404 , (lengthTId , (1, genFCall False ) )
1405 , (nullId , (1, genFCall False ) )
1406 , (hwxorId , (2, genOperator2 AST.Xor ) )
1407 , (hwandId , (2, genOperator2 AST.And ) )
1408 , (hworId , (2, genOperator2 AST.Or ) )
1409 , (hwnotId , (1, genOperator1 AST.Not ) )
1410 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1411 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1412 , (boolOrId , (2, genOperator2 AST.Or ) )
1413 , (boolAndId , (2, genOperator2 AST.And ) )
1414 , (plusId , (2, genOperator2 (AST.:+:) ) )
1415 , (timesId , (2, genOperator2 (AST.:*:) ) )
1416 , (negateId , (1, genNegation ) )
1417 , (minusId , (2, genOperator2 (AST.:-:) ) )
1418 , (fromSizedWordId , (1, genFromSizedWord ) )
1419 , (fromIntegerId , (1, genFromInteger ) )
1420 , (resizeId , (1, genResize ) )
1421 , (sizedIntId , (1, genSizedInt ) )
1422 , (smallIntegerId , (1, genFromInteger ) )
1423 , (fstId , (1, genFst ) )
1424 , (sndId , (1, genSnd ) )
1425 --, (tfvecId , (1, genTFVec ) )
1426 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))