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
9 import qualified Data.Accessor.Monad.Trans.State as MonadState
12 import qualified Language.VHDL.AST as AST
15 import qualified CoreSyn
19 import qualified IdInfo
20 import qualified Literal
22 import qualified TyCon
25 import CLasH.Translator.TranslatorTypes
26 import CLasH.VHDL.Constants
27 import CLasH.VHDL.VHDLTypes
28 import CLasH.VHDL.VHDLTools
30 import CLasH.Utils.Core.CoreTools
31 import CLasH.Utils.Pretty
32 import qualified CLasH.Normalize as Normalize
34 -----------------------------------------------------------------------------
35 -- Functions to generate VHDL for user-defined functions.
36 -----------------------------------------------------------------------------
38 -- | Create an entity for a given function
41 -> TranslatorSession Entity -- ^ The resulting entity
43 getEntity fname = makeCached fname tsEntities $ do
44 expr <- Normalize.getNormalized fname
45 -- Split the normalized expression
46 let (args, binds, res) = Normalize.splitNormalized expr
47 -- Generate ports for all non-empty types
48 args' <- catMaybesM $ mapM mkMap args
49 -- TODO: Handle Nothing
51 count <- MonadState.get tsEntityCounter
52 let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
53 MonadState.set tsEntityCounter (count + 1)
54 let ent_decl = createEntityAST vhdl_id args' res'
55 let signature = Entity vhdl_id args' res' ent_decl
59 --[(SignalId, SignalInfo)]
61 -> TranslatorSession (Maybe Port)
64 --info = Maybe.fromMaybe
65 -- (error $ "Signal not found in the name map? This should not happen!")
67 -- Assume the bndr has a valid VHDL id already
70 error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr
72 type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
73 case type_mark_maybe of
74 Just type_mark -> return $ Just (id, type_mark)
75 Nothing -> return Nothing
78 -- | Create the VHDL AST for an entity
80 AST.VHDLId -- ^ The name of the function
81 -> [Port] -- ^ The entity's arguments
82 -> Maybe Port -- ^ The entity's result
83 -> AST.EntityDec -- ^ The entity with the ent_decl filled in as well
85 createEntityAST vhdl_id args res =
86 AST.EntityDec vhdl_id ports
88 -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
89 ports = map (mkIfaceSigDec AST.In) args
90 ++ (Maybe.maybeToList res_port)
91 ++ [clk_port,resetn_port]
92 -- Add a clk port if we have state
93 clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
94 resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
95 res_port = fmap (mkIfaceSigDec AST.Out) res
97 -- | Create a port declaration
99 AST.Mode -- ^ The mode for the port (In / Out)
100 -> Port -- ^ The id and type for the port
101 -> AST.IfaceSigDec -- ^ The resulting port declaration
103 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
105 -- | Create an architecture for a given function
107 CoreSyn.CoreBndr -- ^ The function to get an architecture for
108 -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
109 -- ^ The architecture for this function
111 getArchitecture fname = makeCached fname tsArchitectures $ do
112 expr <- Normalize.getNormalized fname
113 -- Split the normalized expression
114 let (args, binds, res) = Normalize.splitNormalized expr
116 -- Get the entity for this function
117 signature <- getEntity fname
118 let entity_id = ent_id signature
120 -- Create signal declarations for all binders in the let expression, except
121 -- for the output port (that will already have an output port declared in
123 sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
124 let sig_decs = Maybe.catMaybes sig_dec_maybes
125 -- Process each bind, resulting in info about state variables and concurrent
127 (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
128 let (in_state_maybes, out_state_maybes) = unzip state_vars
129 let (statementss, used_entitiess) = unzip sms
130 -- Get initial state, if it's there
131 initSmap <- MonadState.get tsInitStates
132 let init_state = Map.lookup fname initSmap
133 -- Create a state proc, if needed
134 (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
135 ([in_state], [out_state], Nothing) -> do
136 nonEmpty <- hasNonEmptyType in_state
138 then error ("No initial state defined for: " ++ show fname)
140 ([in_state], [out_state], Just resetval) -> do
141 nonEmpty <- hasNonEmptyType in_state
143 then mkStateProcSm (in_state, out_state, resetval)
144 else error ("Initial state defined for function with only substate: " ++ show fname)
145 ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
146 ([], [], Nothing) -> return ([],[])
147 (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
148 -- Join the create statements and the (optional) state_proc
149 let statements = concat statementss ++ state_proc
150 -- Create the architecture
151 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
152 let used_entities = (concat used_entitiess) ++ resbndr
153 return (arch, used_entities)
155 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
156 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
157 -- ^ ((Input state variable, output state variable), (statements, used entities))
158 -- newtype unpacking is just a cast
159 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
160 | hasStateType packed && not (hasStateType unpacked)
161 = return ((Just bndr, Nothing), ([], []))
162 -- With simplCore, newtype packing is just a cast
163 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
164 | hasStateType packed && not (hasStateType unpacked)
165 = return ((Nothing, Just state), ([], []))
166 -- Without simplCore, newtype packing uses a data constructor
167 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
169 = return ((Nothing, Just state), ([], []))
170 -- Anything else is handled by mkConcSm
173 return ((Nothing, Nothing), sms)
176 (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
177 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
178 mkStateProcSm (old, new, res) = do
179 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
180 type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
181 let type_mark_old = Maybe.fromMaybe
182 (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
184 type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
185 let type_mark_res' = Maybe.fromMaybe
186 (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
188 let type_mark_res = if type_mark_old == type_mark_res' then
191 error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
192 let resvalid = mkVHDLExtId $ varToString res ++ "val"
193 let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
194 let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
195 let res_assign = AST.SigAssign (varToVHDLName old) reswform
196 let blocklabel = mkVHDLBasicId "state"
197 let statelabel = mkVHDLBasicId "stateupdate"
198 let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
199 let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
200 let clk_assign = AST.SigAssign (varToVHDLName old) wform
201 let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
202 let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
203 signature <- getEntity res
204 let entity_id = ent_id signature
205 let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
206 let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
207 let reset_statement = mkComponentInst reslabel entity_id portmaps
208 let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
209 let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
210 let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
211 let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
212 return ([block],[res])
214 -- | Transforms a core binding into a VHDL concurrent statement
216 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
217 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
218 -- ^ The corresponding VHDL concurrent statements and entities
222 -- Ignore Cast expressions, they should not longer have any meaning as long as
223 -- the type works out. Throw away state repacking
224 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
225 | hasStateType to && hasStateType from
227 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
229 -- Simple a = b assignments are just like applications, but without arguments.
230 -- We can't just generate an unconditional assignment here, since b might be a
231 -- top level binding (e.g., a function with no arguments).
232 mkConcSm (bndr, CoreSyn.Var v) =
233 genApplication (Left bndr) v []
235 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
236 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
237 let valargs = get_val_args (Var.varType f) args
238 genApplication (Left bndr) f (map Left valargs)
240 -- A single alt case must be a selector. This means the scrutinee is a simple
241 -- variable, the alternative is a dataalt with a single non-wild binder that
243 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
244 -- Don't generate VHDL for substate extraction
245 | hasStateType bndr = return ([], [])
248 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
249 nonemptysel <- hasNonEmptyType sel_bndr
252 bndrs' <- Monad.filterM hasNonEmptyType bndrs
253 case List.elemIndex sel_bndr bndrs' of
255 htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
256 htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
257 case htypeScrt == htypeBndr of
259 let sel_name = varToVHDLName scrut
260 let sel_expr = AST.PrimName sel_name
261 return ([mkUncondAssign (Left bndr) sel_expr], [])
264 Right (AggrType _ _) -> do
265 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
266 let label = labels!!i
267 let sel_name = mkSelectedName (varToVHDLName scrut) label
268 let sel_expr = AST.PrimName sel_name
269 return ([mkUncondAssign (Left bndr) sel_expr], [])
270 _ -> do -- error $ "DIE!"
271 let sel_name = varToVHDLName scrut
272 let sel_expr = AST.PrimName sel_name
273 return ([mkUncondAssign (Left bndr) sel_expr], [])
274 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
276 -- A selector case that selects a state value, ignore it.
279 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
281 -- Multiple case alt are be conditional assignments and have only wild
282 -- binders in the alts and only variables in the case values and a variable
283 -- for a scrutinee. We check the constructor of the second alt, since the
284 -- first is the default case, if there is any.
286 -- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
287 -- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
288 -- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
289 -- let cond_expr = scrut' AST.:=: altcon
290 -- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
291 -- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
292 -- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
293 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
294 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
295 -- Omit first condition, which is the default
296 altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
297 let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
298 -- Rotate expressions to the left, so that the expression related to the default case is the last
299 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
300 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
302 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
303 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
305 -----------------------------------------------------------------------------
306 -- Functions to generate VHDL for builtin functions
307 -----------------------------------------------------------------------------
309 -- | A function to wrap a builder-like function that expects its arguments to
311 genExprArgs wrap dst func args = do
312 args' <- argsToVHDLExprs args
315 -- | Turn the all lefts into VHDL Expressions.
316 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
317 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
319 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
320 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
321 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
322 ty_maybe <- vhdlTy errmsg expr
325 vhdl_expr <- varToVHDLExpr $ exprToVar expr
326 return $ Just vhdl_expr
327 Nothing -> return Nothing
329 argToVHDLExpr (Right expr) = return $ Just expr
331 -- A function to wrap a builder-like function that generates no component
334 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
335 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
336 genNoInsts wrap dst func args = do
337 concsms <- wrap dst func args
340 -- | A function to wrap a builder-like function that expects its arguments to
343 (dst -> func -> [Var.Var] -> res)
344 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
345 genVarArgs wrap dst func args = wrap dst func args'
347 args' = map exprToVar exprargs
348 -- Check (rather crudely) that all arguments are CoreExprs
349 (exprargs, []) = Either.partitionEithers args
351 -- | A function to wrap a builder-like function that expects its arguments to
354 (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
355 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
356 genLitArgs wrap dst func args = do
357 hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
358 let (exprargs, []) = Either.partitionEithers args
359 -- FIXME: Check if we were passed an CoreSyn.App
360 let litargs = concatMap (getLiterals hscenv) exprargs
361 let args' = map exprToLit litargs
364 -- | A function to wrap a builder-like function that produces an expression
365 -- and expects it to be assigned to the destination.
367 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
368 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
369 genExprRes wrap dst func args = do
370 expr <- wrap dst func args
371 return [mkUncondAssign dst expr]
373 -- | Generate a binary operator application. The first argument should be a
374 -- constructor from the AST.Expr type, e.g. AST.And.
375 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
376 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
377 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
378 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
380 -- | Generate a unary operator application
381 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
382 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
383 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
384 genOperator1' op _ f [arg] = return $ op arg
386 -- | Generate a unary operator application
387 genNegation :: BuiltinBuilder
388 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
389 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
390 genNegation' _ f [arg] = do
391 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
392 let ty = Var.varType arg
393 let (tycon, args) = Type.splitTyConApp ty
394 let name = Name.getOccString (TyCon.tyConName tycon)
396 "SizedInt" -> return $ AST.Neg arg1
397 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
399 -- | Generate a function call from the destination binder, function name and a
400 -- list of expressions (its arguments)
401 genFCall :: Bool -> BuiltinBuilder
402 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
403 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
404 genFCall' switch (Left res) f args = do
405 let fname = varToString f
406 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
407 id <- MonadState.lift tsType $ vectorFunId el_ty fname
408 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
409 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
410 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
412 genFromSizedWord :: BuiltinBuilder
413 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
414 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
415 genFromSizedWord' (Left res) f args@[arg] =
416 return [mkUncondAssign (Left res) arg]
417 -- let fname = varToString f
418 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
419 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
420 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
422 genResize :: BuiltinBuilder
423 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
424 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
425 genResize' (Left res) f [arg] = do {
426 ; let { ty = Var.varType res
427 ; (tycon, args) = Type.splitTyConApp ty
428 ; name = Name.getOccString (TyCon.tyConName tycon)
430 ; len <- case name of
431 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
432 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
433 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
434 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
436 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
438 genTimes :: BuiltinBuilder
439 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
440 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
441 genTimes' (Left res) f [arg1,arg2] = do {
442 ; let { ty = Var.varType res
443 ; (tycon, args) = Type.splitTyConApp ty
444 ; name = Name.getOccString (TyCon.tyConName tycon)
446 ; len <- case name of
447 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
448 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
449 "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
450 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
453 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
454 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
456 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
458 -- FIXME: I'm calling genLitArgs which is very specific function,
459 -- which needs to be fixed as well
460 genFromInteger :: BuiltinBuilder
461 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
462 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
463 genFromInteger' (Left res) f lits = do {
464 ; let { ty = Var.varType res
465 ; (tycon, args) = Type.splitTyConApp ty
466 ; name = Name.getOccString (TyCon.tyConName tycon)
468 ; len <- case name of
469 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
470 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
472 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
473 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
475 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
476 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
477 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
481 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
483 genSizedInt :: BuiltinBuilder
484 genSizedInt = genFromInteger
487 -- | Generate a Builder for the builtin datacon TFVec
488 genTFVec :: BuiltinBuilder
489 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
490 -- Generate Assignments for all the binders
491 ; letAssigns <- mapM genBinderAssign letBinders
492 -- Generate assignments for the result (which might be another let binding)
493 ; (resBinders,resAssignments) <- genResAssign letRes
494 -- Get all the Assigned binders
495 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
496 -- Make signal names for all the assigned binders
497 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
498 -- Assign all the signals to the resulting vector
499 ; let { vecsigns = mkAggregateSignal sigs
500 ; vecassign = mkUncondAssign (Left res) vecsigns
502 -- Generate all the signal declaration for the assigned binders
503 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
504 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
505 -- Setup the VHDL Block
506 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
507 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
509 -- Return the block statement coressponding to the TFVec literal
510 ; return $ [AST.CSBSm block]
513 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
514 -- For now we only translate applications
515 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
516 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
517 let valargs = get_val_args (Var.varType f) args
518 apps <- genApplication (Left bndr) f (map Left valargs)
519 return (Just bndr, apps)
520 genBinderAssign _ = return (Nothing,[])
521 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
522 genResAssign app@(CoreSyn.App _ letexpr) = do
524 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
525 letapps <- mapM genBinderAssign letbndrs
526 let bndrs = Maybe.catMaybes (map fst letapps)
527 let app = (map snd letapps)
528 (vars, apps) <- genResAssign letres
529 return ((bndrs ++ vars),((concat app) ++ apps))
530 otherwise -> return ([],[])
531 genResAssign _ = return ([],[])
533 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
534 ; let { elems = reduceCoreListToHsList app
535 -- Make signal names for all the binders
536 ; binders = map (\expr -> case expr of
538 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
539 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
541 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
542 -- Assign all the signals to the resulting vector
543 ; let { vecsigns = mkAggregateSignal sigs
544 ; vecassign = mkUncondAssign (Left res) vecsigns
545 -- Setup the VHDL Block
546 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
547 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
549 -- Return the block statement coressponding to the TFVec literal
550 ; return $ [AST.CSBSm block]
553 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
555 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
557 -- | Generate a generate statement for the builtin function "map"
558 genMap :: BuiltinBuilder
559 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
560 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
561 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
562 -- we must index it (which we couldn't if it was a VHDL Expr, since only
563 -- VHDLNames can be indexed).
564 -- Setup the generate scheme
565 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
566 -- TODO: Use something better than varToString
567 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
568 ; n_id = mkVHDLBasicId "n"
569 ; n_expr = idToVHDLExpr n_id
570 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
571 ; genScheme = AST.ForGn n_id range
572 -- Create the content of the generate statement: Applying the mapped_f to
573 -- each of the elements in arg, storing to each element in res
574 ; resname = mkIndexedName (varToVHDLName res) n_expr
575 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
576 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
577 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
579 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
580 -- Return the generate statement
581 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
584 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
586 genZipWith :: BuiltinBuilder
587 genZipWith = genVarArgs genZipWith'
588 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
589 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
590 -- Setup the generate scheme
591 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
592 -- TODO: Use something better than varToString
593 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
594 ; n_id = mkVHDLBasicId "n"
595 ; n_expr = idToVHDLExpr n_id
596 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
597 ; genScheme = AST.ForGn n_id range
598 -- Create the content of the generate statement: Applying the zipped_f to
599 -- each of the elements in arg1 and arg2, storing to each element in res
600 ; resname = mkIndexedName (varToVHDLName res) n_expr
601 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
602 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
604 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
605 -- Return the generate functions
606 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
609 genFoldl :: BuiltinBuilder
610 genFoldl = genFold True
612 genFoldr :: BuiltinBuilder
613 genFoldr = genFold False
615 genFold :: Bool -> BuiltinBuilder
616 genFold left = genVarArgs (genFold' left)
618 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
619 genFold' left res f args@[folded_f , start ,vec]= do
620 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
621 genFold'' len left res f args
623 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
624 -- Special case for an empty input vector, just assign start to res
625 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
626 arg <- MonadState.lift tsType $ varToVHDLExpr start
627 return ([mkUncondAssign (Left res) arg], [])
629 genFold'' len left (Left res) f [folded_f, start, vec] = do
631 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
632 -- An expression for len-1
633 let len_min_expr = (AST.PrimLit $ show (len-1))
634 -- evec is (TFVec n), so it still needs an element type
635 let (nvec, _) = Type.splitAppTy (Var.varType vec)
636 -- Put the type of the start value in nvec, this will be the type of our
638 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
639 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
640 -- TODO: Handle Nothing
641 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
642 -- Setup the generate scheme
643 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
644 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
645 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
646 else AST.DownRange len_min_expr (AST.PrimLit "0")
647 let gen_scheme = AST.ForGn n_id gen_range
648 -- Make the intermediate vector
649 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
650 -- Create the generate statement
651 cells' <- sequence [genFirstCell, genOtherCell]
652 let (cells, useds) = unzip cells'
653 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
654 -- Assign tmp[len-1] or tmp[0] to res
655 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
656 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
657 (mkIndexedName tmp_name (AST.PrimLit "0")))
658 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
659 return ([AST.CSBSm block], concat useds)
661 -- An id for the counter
662 n_id = mkVHDLBasicId "n"
663 n_cur = idToVHDLExpr n_id
664 -- An expression for previous n
665 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
666 else (n_cur AST.:+: (AST.PrimLit "1"))
667 -- An id for the tmp result vector
668 tmp_id = mkVHDLBasicId "tmp"
669 tmp_name = AST.NSimple tmp_id
670 -- Generate parts of the fold
671 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
673 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
674 let cond_label = mkVHDLExtId "firstcell"
675 -- if n == 0 or n == len-1
676 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
677 else (AST.PrimLit $ show (len-1)))
678 -- Output to tmp[current n]
679 let resname = mkIndexedName tmp_name n_cur
681 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
682 -- Input from vec[current n]
683 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
684 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
685 [Right argexpr1, Right argexpr2]
687 [Right argexpr2, Right argexpr1]
689 -- Return the conditional generate part
690 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
693 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
694 let cond_label = mkVHDLExtId "othercell"
695 -- if n > 0 or n < len-1
696 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
697 else (AST.PrimLit $ show (len-1)))
698 -- Output to tmp[current n]
699 let resname = mkIndexedName tmp_name n_cur
700 -- Input from tmp[previous n]
701 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
702 -- Input from vec[current n]
703 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
704 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
705 [Right argexpr1, Right argexpr2]
707 [Right argexpr2, Right argexpr1]
709 -- Return the conditional generate part
710 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
712 -- | Generate a generate statement for the builtin function "zip"
713 genZip :: BuiltinBuilder
714 genZip = genNoInsts $ genVarArgs genZip'
715 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
716 genZip' (Left res) f args@[arg1, arg2] = do {
717 -- Setup the generate scheme
718 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
719 -- TODO: Use something better than varToString
720 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
721 ; n_id = mkVHDLBasicId "n"
722 ; n_expr = idToVHDLExpr n_id
723 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
724 ; genScheme = AST.ForGn n_id range
725 ; resname' = mkIndexedName (varToVHDLName res) n_expr
726 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
727 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
729 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
730 ; let { resnameA = mkSelectedName resname' (labels!!0)
731 ; resnameB = mkSelectedName resname' (labels!!1)
732 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
733 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
735 -- Return the generate functions
736 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
739 -- | Generate a generate statement for the builtin function "fst"
740 genFst :: BuiltinBuilder
741 genFst = genNoInsts $ genVarArgs genFst'
742 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
743 genFst' (Left res) f args@[arg] = do {
744 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
745 ; let { argexpr' = varToVHDLName arg
746 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
747 ; assign = mkUncondAssign (Left res) argexprA
749 -- Return the generate functions
753 -- | Generate a generate statement for the builtin function "snd"
754 genSnd :: BuiltinBuilder
755 genSnd = genNoInsts $ genVarArgs genSnd'
756 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
757 genSnd' (Left res) f args@[arg] = do {
758 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
759 ; let { argexpr' = varToVHDLName arg
760 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
761 ; assign = mkUncondAssign (Left res) argexprB
763 -- Return the generate functions
767 -- | Generate a generate statement for the builtin function "unzip"
768 genUnzip :: BuiltinBuilder
769 genUnzip = genNoInsts $ genVarArgs genUnzip'
770 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
771 genUnzip' (Left res) f args@[arg] = do
772 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
773 htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
774 -- Prepare a unconditional assignment, for the case when either part
775 -- of the unzip is a state variable, which will disappear in the
776 -- resulting VHDL, making the the unzip no longer required.
778 -- A normal vector containing two-tuples
779 VecType _ (AggrType _ [_, _]) -> do {
780 -- Setup the generate scheme
781 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
782 -- TODO: Use something better than varToString
783 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
784 ; n_id = mkVHDLBasicId "n"
785 ; n_expr = idToVHDLExpr n_id
786 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
787 ; genScheme = AST.ForGn n_id range
788 ; resname' = varToVHDLName res
789 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
791 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
792 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
793 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
794 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
795 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
796 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
797 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
798 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
800 -- Return the generate functions
801 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
803 -- Both elements of the tuple were state, so they've disappeared. No
804 -- need to do anything
805 VecType _ (AggrType _ []) -> return []
806 -- A vector containing aggregates with more than two elements?
807 VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
808 -- One of the elements of the tuple was state, so there won't be a
809 -- tuple (record) in the VHDL output. We can just do a plain
812 argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
813 return [mkUncondAssign (Left res) argexpr]
814 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
816 genCopy :: BuiltinBuilder
817 genCopy = genNoInsts $ genVarArgs genCopy'
818 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
819 genCopy' (Left res) f args@[arg] =
821 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
822 (AST.PrimName (varToVHDLName arg))]
823 out_assign = mkUncondAssign (Left res) resExpr
827 genConcat :: BuiltinBuilder
828 genConcat = genNoInsts $ genVarArgs genConcat'
829 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
830 genConcat' (Left res) f args@[arg] = do {
831 -- Setup the generate scheme
832 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
833 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
834 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
835 -- TODO: Use something better than varToString
836 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
837 ; n_id = mkVHDLBasicId "n"
838 ; n_expr = idToVHDLExpr n_id
839 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
840 ; genScheme = AST.ForGn n_id range
841 -- Create the content of the generate statement: Applying the mapped_f to
842 -- each of the elements in arg, storing to each element in res
843 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
844 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
845 ; resname = vecSlice fromRange toRange
846 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
847 ; out_assign = mkUncondAssign (Right resname) argexpr
849 -- Return the generate statement
850 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
853 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
854 (AST.ToRange init last))
856 genIteraten :: BuiltinBuilder
857 genIteraten dst f args = genIterate dst f (tail args)
859 genIterate :: BuiltinBuilder
860 genIterate = genIterateOrGenerate True
862 genGeneraten :: BuiltinBuilder
863 genGeneraten dst f args = genGenerate dst f (tail args)
865 genGenerate :: BuiltinBuilder
866 genGenerate = genIterateOrGenerate False
868 genIterateOrGenerate :: Bool -> BuiltinBuilder
869 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
871 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
872 genIterateOrGenerate' iter (Left res) f args = do
873 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
874 genIterateOrGenerate'' len iter (Left res) f args
876 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
877 -- Special case for an empty input vector, just assign start to res
878 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
880 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
882 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
883 -- An expression for len-1
884 let len_min_expr = (AST.PrimLit $ show (len-1))
885 -- -- evec is (TFVec n), so it still needs an element type
886 -- let (nvec, _) = splitAppTy (Var.varType vec)
887 -- -- Put the type of the start value in nvec, this will be the type of our
888 -- -- temporary vector
889 let tmp_ty = Var.varType res
890 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
891 -- TODO: Handle Nothing
892 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
893 -- Setup the generate scheme
894 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
895 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
896 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
897 let gen_scheme = AST.ForGn n_id gen_range
898 -- Make the intermediate vector
899 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
900 -- Create the generate statement
901 cells' <- sequence [genFirstCell, genOtherCell]
902 let (cells, useds) = unzip cells'
903 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
904 -- Assign tmp[len-1] or tmp[0] to res
905 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
906 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
907 return ([AST.CSBSm block], concat useds)
909 -- An id for the counter
910 n_id = mkVHDLBasicId "n"
911 n_cur = idToVHDLExpr n_id
912 -- An expression for previous n
913 n_prev = n_cur AST.:-: (AST.PrimLit "1")
914 -- An id for the tmp result vector
915 tmp_id = mkVHDLBasicId "tmp"
916 tmp_name = AST.NSimple tmp_id
917 -- Generate parts of the fold
918 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
920 let cond_label = mkVHDLExtId "firstcell"
921 -- if n == 0 or n == len-1
922 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
923 -- Output to tmp[current n]
924 let resname = mkIndexedName tmp_name n_cur
926 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
927 let startassign = mkUncondAssign (Right resname) argexpr
928 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
929 -- Return the conditional generate part
930 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
938 let cond_label = mkVHDLExtId "othercell"
939 -- if n > 0 or n < len-1
940 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
941 -- Output to tmp[current n]
942 let resname = mkIndexedName tmp_name n_cur
943 -- Input from tmp[previous n]
944 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
945 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
946 -- Return the conditional generate part
947 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
949 genBlockRAM :: BuiltinBuilder
950 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
952 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
953 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
955 let (tup,data_out) = Type.splitAppTy (Var.varType res)
956 let (tup',ramvec) = Type.splitAppTy tup
957 let Just realram = Type.coreView ramvec
958 let Just (tycon, types) = Type.splitTyConApp_maybe realram
959 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
960 -- Make the intermediate vector
961 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
962 -- Get the data_out name
963 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
964 let resname = varToVHDLName res
965 -- let resname = mkSelectedName resname' (reslabels!!0)
966 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
967 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
968 let assign = mkUncondAssign (Right resname) argexpr
969 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
970 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
971 return [AST.CSBSm block]
973 ram_id = mkVHDLBasicId "ram"
974 mkUpdateProcSm :: AST.ConcSm
975 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
977 proclabel = mkVHDLBasicId "updateRAM"
978 rising_edge = mkVHDLBasicId "rising_edge"
979 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
980 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
981 wform = AST.Wform [AST.WformElem data_in Nothing]
982 ramassign = AST.SigAssign ramloc wform
983 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
984 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
986 genSplit :: BuiltinBuilder
987 genSplit = genNoInsts $ genVarArgs genSplit'
989 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
990 genSplit' (Left res) f args@[vecIn] = do {
991 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
992 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
993 ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
994 ; halflen = round ((fromIntegral len) / 2)
995 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
996 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
997 ; resname = varToVHDLName res
998 ; resnameL = mkSelectedName resname (labels!!0)
999 ; resnameR = mkSelectedName resname (labels!!1)
1000 ; argexprL = vhdlNameToVHDLExpr rangeL
1001 ; argexprR = vhdlNameToVHDLExpr rangeR
1002 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1003 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1004 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1006 ; return [AST.CSBSm block]
1009 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1010 (AST.ToRange init last))
1011 -----------------------------------------------------------------------------
1012 -- Function to generate VHDL for applications
1013 -----------------------------------------------------------------------------
1015 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
1016 -> CoreSyn.CoreBndr -- ^ The function to apply
1017 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
1018 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1019 -- ^ The corresponding VHDL concurrent statements and entities
1021 genApplication dst f args = do
1022 nonemptydst <- case dst of
1023 Left bndr -> hasNonEmptyType bndr
1024 Right _ -> return True
1027 if Var.isGlobalId f then
1028 case Var.idDetails f of
1029 IdInfo.DataConWorkId dc -> case dst of
1030 -- It's a datacon. Create a record from its arguments.
1032 -- We have the bndr, so we can get at the type
1033 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1034 let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
1037 [arg'] <- argsToVHDLExprs [arg]
1038 return ([mkUncondAssign dst arg'], [])
1041 Right (AggrType _ _) -> do
1042 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
1043 args' <- argsToVHDLExprs argsNostate
1044 return (zipWith mkassign labels args', [])
1046 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1047 mkassign label arg =
1048 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1049 mkUncondAssign (Right sel_name) arg
1050 _ -> do -- error $ "DIE!"
1051 args' <- argsToVHDLExprs argsNostate
1052 return ([mkUncondAssign dst (head args')], [])
1053 Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1054 IdInfo.DataConWrapId dc -> case dst of
1055 -- It's a datacon. Create a record from its arguments.
1057 case (Map.lookup (varToString f) globalNameTable) of
1058 Just (arg_count, builder) ->
1059 if length args == arg_count then
1062 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1063 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1064 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1066 -- It's a global value imported from elsewhere. These can be builtin
1067 -- functions. Look up the function name in the name table and execute
1068 -- the associated builder if there is any and the argument count matches
1069 -- (this should always be the case if it typechecks, but just to be
1071 case (Map.lookup (varToString f) globalNameTable) of
1072 Just (arg_count, builder) ->
1073 if length args == arg_count then
1076 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1078 top <- isTopLevelBinder f
1081 -- Local binder that references a top level binding. Generate a
1082 -- component instantiation.
1083 signature <- getEntity f
1084 args' <- argsToVHDLExprs args
1085 let entity_id = ent_id signature
1086 -- TODO: Using show here isn't really pretty, but we'll need some
1087 -- unique-ish value...
1088 let label = "comp_ins_" ++ (either show prettyShow) dst
1089 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1090 return ([mkComponentInst label entity_id portmaps], [f])
1092 -- Not a top level binder, so this must be a local variable reference.
1093 -- It should have a representable type (and thus, no arguments) and a
1094 -- signal should be generated for it. Just generate an unconditional
1096 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1097 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1098 -- return $ ([mkUncondAssign dst f'], [])
1099 do errtype <- case dst of
1101 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1103 Right vhd -> return $ show vhd
1104 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1105 IdInfo.ClassOpId cls ->
1106 -- FIXME: Not looking for what instance this class op is called for
1107 -- Is quite stupid of course.
1108 case (Map.lookup (varToString f) globalNameTable) of
1109 Just (arg_count, builder) ->
1110 if length args == arg_count then
1113 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1114 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1115 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1117 top <- isTopLevelBinder f
1120 -- Local binder that references a top level binding. Generate a
1121 -- component instantiation.
1122 signature <- getEntity f
1123 args' <- argsToVHDLExprs args
1124 let entity_id = ent_id signature
1125 -- TODO: Using show here isn't really pretty, but we'll need some
1126 -- unique-ish value...
1127 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1128 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1129 return ([mkComponentInst label entity_id portmaps], [f])
1131 -- Not a top level binder, so this must be a local variable reference.
1132 -- It should have a representable type (and thus, no arguments) and a
1133 -- signal should be generated for it. Just generate an unconditional
1135 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1136 return ([mkUncondAssign dst f'], [])
1137 else -- Destination has empty type, don't generate anything
1139 -----------------------------------------------------------------------------
1140 -- Functions to generate functions dealing with vectors.
1141 -----------------------------------------------------------------------------
1143 -- Returns the VHDLId of the vector function with the given name for the given
1144 -- element type. Generates -- this function if needed.
1145 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1146 vectorFunId el_ty fname = do
1147 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1148 -- TODO: Handle the Nothing case?
1149 elemTM_maybe <- vhdlTy error_msg el_ty
1150 let elemTM = Maybe.fromMaybe
1151 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1153 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1154 -- the VHDLState or something.
1155 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1156 typefuns <- MonadState.get tsTypeFuns
1157 el_htype <- mkHType error_msg el_ty
1158 case Map.lookup (UVecType el_htype, fname) typefuns of
1159 -- Function already generated, just return it
1160 Just (id, _) -> return id
1161 -- Function not generated yet, generate it
1163 let functions = genUnconsVectorFuns elemTM vectorTM
1164 case lookup fname functions of
1166 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1167 mapM_ (vectorFunId el_ty) (snd body)
1169 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1171 function_id = mkVHDLExtId fname
1173 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1174 -> AST.TypeMark -- ^ type of the vector
1175 -> [(String, (AST.SubProgBody, [String]))]
1176 genUnconsVectorFuns elemTM vectorTM =
1177 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1178 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1179 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1180 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1181 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1182 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1183 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1184 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1185 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1186 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1187 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1188 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1189 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1190 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1191 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1192 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1193 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1194 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1195 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1196 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1197 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1200 ixPar = AST.unsafeVHDLBasicId "ix"
1201 vecPar = AST.unsafeVHDLBasicId "vec"
1202 vec1Par = AST.unsafeVHDLBasicId "vec1"
1203 vec2Par = AST.unsafeVHDLBasicId "vec2"
1204 nPar = AST.unsafeVHDLBasicId "n"
1205 leftPar = AST.unsafeVHDLBasicId "nLeft"
1206 rightPar = AST.unsafeVHDLBasicId "nRight"
1207 iId = AST.unsafeVHDLBasicId "i"
1209 aPar = AST.unsafeVHDLBasicId "a"
1210 fPar = AST.unsafeVHDLBasicId "f"
1211 sPar = AST.unsafeVHDLBasicId "s"
1212 resId = AST.unsafeVHDLBasicId "res"
1213 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1214 AST.IfaceVarDec ixPar unsignedTM] elemTM
1215 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1216 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1217 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1218 , AST.IfaceVarDec iPar unsignedTM
1219 , AST.IfaceVarDec aPar elemTM
1221 -- variable res : fsvec_x (0 to vec'length-1);
1224 (AST.SubtypeIn vectorTM
1225 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1226 [AST.ToRange (AST.PrimLit "0")
1227 (AST.PrimName (AST.NAttribute $
1228 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1229 (AST.PrimLit "1")) ]))
1231 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1232 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1233 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1234 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1235 vecSlice init last = AST.PrimName (AST.NSlice
1237 (AST.NSimple vecPar)
1238 (AST.ToRange init last)))
1239 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1240 -- return vec(vec'length-1);
1241 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1242 (AST.NSimple vecPar)
1243 [AST.PrimName (AST.NAttribute $
1244 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1245 AST.:-: AST.PrimLit "1"])))
1246 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1247 -- variable res : fsvec_x (0 to vec'length-2);
1250 (AST.SubtypeIn vectorTM
1251 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1252 [AST.ToRange (AST.PrimLit "0")
1253 (AST.PrimName (AST.NAttribute $
1254 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1255 (AST.PrimLit "2")) ]))
1257 -- resAST.:= vec(0 to vec'length-2)
1258 initExpr = AST.NSimple resId AST.:= (vecSlice
1260 (AST.PrimName (AST.NAttribute $
1261 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1262 AST.:-: AST.PrimLit "2"))
1263 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1264 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1265 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1266 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1267 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1269 (Just $ AST.Else [minimumExprRet])
1270 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1271 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1272 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1273 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1274 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1275 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1276 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1277 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1280 (AST.SubtypeIn vectorTM
1281 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1282 [AST.ToRange (AST.PrimLit "0")
1284 (AST.PrimLit "1")) ]))
1286 -- res AST.:= vec(0 to n-1)
1287 takeExpr = AST.NSimple resId AST.:=
1288 (vecSlice (AST.PrimLit "0")
1289 (minLength AST.:-: AST.PrimLit "1"))
1290 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1291 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1292 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1293 -- variable res : fsvec_x (0 to vec'length-n-1);
1296 (AST.SubtypeIn vectorTM
1297 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1298 [AST.ToRange (AST.PrimLit "0")
1299 (AST.PrimName (AST.NAttribute $
1300 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1301 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1303 -- res AST.:= vec(n to vec'length-1)
1304 dropExpr = AST.NSimple resId AST.:= (vecSlice
1305 (AST.PrimName $ AST.NSimple nPar)
1306 (AST.PrimName (AST.NAttribute $
1307 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1308 AST.:-: AST.PrimLit "1"))
1309 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1310 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1311 AST.IfaceVarDec vecPar vectorTM] vectorTM
1312 -- variable res : fsvec_x (0 to vec'length);
1315 (AST.SubtypeIn vectorTM
1316 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1317 [AST.ToRange (AST.PrimLit "0")
1318 (AST.PrimName (AST.NAttribute $
1319 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1321 plusgtExpr = AST.NSimple resId AST.:=
1322 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1323 (AST.PrimName $ AST.NSimple vecPar))
1324 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1325 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1328 (AST.SubtypeIn vectorTM
1329 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1330 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1332 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1333 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1335 -- variable res : fsvec_x (0 to 0) := (others => a);
1338 (AST.SubtypeIn vectorTM
1339 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1340 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1341 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1342 (AST.PrimName $ AST.NSimple aPar)])
1343 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1344 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1345 AST.IfaceVarDec aPar elemTM ] vectorTM
1346 -- variable res : fsvec_x (0 to n-1) := (others => a);
1349 (AST.SubtypeIn vectorTM
1350 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1351 [AST.ToRange (AST.PrimLit "0")
1352 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1353 (AST.PrimLit "1")) ]))
1354 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1355 (AST.PrimName $ AST.NSimple aPar)])
1357 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1358 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1359 AST.IfaceVarDec sPar naturalTM,
1360 AST.IfaceVarDec nPar naturalTM,
1361 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1362 -- variable res : fsvec_x (0 to n-1);
1365 (AST.SubtypeIn vectorTM
1366 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1367 [AST.ToRange (AST.PrimLit "0")
1368 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1369 (AST.PrimLit "1")) ])
1372 -- for i res'range loop
1373 -- res(i) := vec(f+i*s);
1375 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1376 -- res(i) := vec(f+i*s);
1377 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1378 (AST.PrimName (AST.NSimple iId) AST.:*:
1379 AST.PrimName (AST.NSimple sPar)) in
1380 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1381 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1383 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1384 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1385 AST.IfaceVarDec aPar elemTM] vectorTM
1386 -- variable res : fsvec_x (0 to vec'length);
1389 (AST.SubtypeIn vectorTM
1390 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1391 [AST.ToRange (AST.PrimLit "0")
1392 (AST.PrimName (AST.NAttribute $
1393 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1395 ltplusExpr = AST.NSimple resId AST.:=
1396 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1397 (AST.PrimName $ AST.NSimple aPar))
1398 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1399 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1400 AST.IfaceVarDec vec2Par vectorTM]
1402 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1405 (AST.SubtypeIn vectorTM
1406 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1407 [AST.ToRange (AST.PrimLit "0")
1408 (AST.PrimName (AST.NAttribute $
1409 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1410 AST.PrimName (AST.NAttribute $
1411 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1414 plusplusExpr = AST.NSimple resId AST.:=
1415 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1416 (AST.PrimName $ AST.NSimple vec2Par))
1417 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1418 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1419 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1420 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1421 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1422 AST.IfaceVarDec aPar elemTM ] vectorTM
1423 -- variable res : fsvec_x (0 to vec'length-1);
1426 (AST.SubtypeIn vectorTM
1427 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1428 [AST.ToRange (AST.PrimLit "0")
1429 (AST.PrimName (AST.NAttribute $
1430 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1431 (AST.PrimLit "1")) ]))
1433 -- res := a & init(vec)
1434 shiftlExpr = AST.NSimple resId AST.:=
1435 (AST.PrimName (AST.NSimple aPar) AST.:&:
1436 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1437 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1438 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1439 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1440 AST.IfaceVarDec aPar elemTM ] vectorTM
1441 -- variable res : fsvec_x (0 to vec'length-1);
1444 (AST.SubtypeIn vectorTM
1445 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1446 [AST.ToRange (AST.PrimLit "0")
1447 (AST.PrimName (AST.NAttribute $
1448 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1449 (AST.PrimLit "1")) ]))
1451 -- res := tail(vec) & a
1452 shiftrExpr = AST.NSimple resId AST.:=
1453 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1454 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1455 (AST.PrimName (AST.NSimple aPar)))
1457 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1458 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1459 -- return vec'length = 0
1460 nullExpr = AST.ReturnSm (Just $
1461 AST.PrimName (AST.NAttribute $
1462 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1464 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1465 -- variable res : fsvec_x (0 to vec'length-1);
1468 (AST.SubtypeIn vectorTM
1469 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1470 [AST.ToRange (AST.PrimLit "0")
1471 (AST.PrimName (AST.NAttribute $
1472 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1473 (AST.PrimLit "1")) ]))
1475 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1476 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1477 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1478 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1480 (Just $ AST.Else [rotlExprRet])
1482 AST.NSimple resId AST.:=
1483 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1484 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1485 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1486 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1487 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1488 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1489 -- variable res : fsvec_x (0 to vec'length-1);
1492 (AST.SubtypeIn vectorTM
1493 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1494 [AST.ToRange (AST.PrimLit "0")
1495 (AST.PrimName (AST.NAttribute $
1496 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1497 (AST.PrimLit "1")) ]))
1499 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1500 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1501 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1502 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1504 (Just $ AST.Else [rotrExprRet])
1506 AST.NSimple resId AST.:=
1507 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1508 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1509 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1510 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1511 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1512 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1515 (AST.SubtypeIn vectorTM
1516 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1517 [AST.ToRange (AST.PrimLit "0")
1518 (AST.PrimName (AST.NAttribute $
1519 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1520 (AST.PrimLit "1")) ]))
1522 -- for i in 0 to res'range loop
1523 -- res(vec'length-i-1) := vec(i);
1526 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1527 -- res(vec'length-i-1) := vec(i);
1528 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1529 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1530 [AST.PrimName $ AST.NSimple iId]))
1531 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1532 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1533 AST.PrimName (AST.NSimple iId) AST.:-:
1536 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1539 -----------------------------------------------------------------------------
1540 -- A table of builtin functions
1541 -----------------------------------------------------------------------------
1543 -- A function that generates VHDL for a builtin function
1544 type BuiltinBuilder =
1545 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1546 -> CoreSyn.CoreBndr -- ^ The function called
1547 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1548 -- dictionary arguments).
1549 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1550 -- ^ The corresponding VHDL concurrent statements and entities
1553 -- A map of a builtin function to VHDL function builder
1554 type NameTable = Map.Map String (Int, BuiltinBuilder )
1556 -- | The builtin functions we support. Maps a name to an argument count and a
1557 -- builder function.
1558 globalNameTable :: NameTable
1559 globalNameTable = Map.fromList
1560 [ (exId , (2, genFCall True ) )
1561 , (replaceId , (3, genFCall False ) )
1562 , (headId , (1, genFCall True ) )
1563 , (lastId , (1, genFCall True ) )
1564 , (tailId , (1, genFCall False ) )
1565 , (initId , (1, genFCall False ) )
1566 , (takeId , (2, genFCall False ) )
1567 , (dropId , (2, genFCall False ) )
1568 , (selId , (4, genFCall False ) )
1569 , (plusgtId , (2, genFCall False ) )
1570 , (ltplusId , (2, genFCall False ) )
1571 , (plusplusId , (2, genFCall False ) )
1572 , (mapId , (2, genMap ) )
1573 , (zipWithId , (3, genZipWith ) )
1574 , (foldlId , (3, genFoldl ) )
1575 , (foldrId , (3, genFoldr ) )
1576 , (zipId , (2, genZip ) )
1577 , (unzipId , (1, genUnzip ) )
1578 , (shiftlId , (2, genFCall False ) )
1579 , (shiftrId , (2, genFCall False ) )
1580 , (rotlId , (1, genFCall False ) )
1581 , (rotrId , (1, genFCall False ) )
1582 , (concatId , (1, genConcat ) )
1583 , (reverseId , (1, genFCall False ) )
1584 , (iteratenId , (3, genIteraten ) )
1585 , (iterateId , (2, genIterate ) )
1586 , (generatenId , (3, genGeneraten ) )
1587 , (generateId , (2, genGenerate ) )
1588 , (emptyId , (0, genFCall False ) )
1589 , (singletonId , (1, genFCall False ) )
1590 , (copynId , (2, genFCall False ) )
1591 , (copyId , (1, genCopy ) )
1592 , (lengthTId , (1, genFCall False ) )
1593 , (nullId , (1, genFCall False ) )
1594 , (hwxorId , (2, genOperator2 AST.Xor ) )
1595 , (hwandId , (2, genOperator2 AST.And ) )
1596 , (hworId , (2, genOperator2 AST.Or ) )
1597 , (hwnotId , (1, genOperator1 AST.Not ) )
1598 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1599 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1600 , (ltId , (2, genOperator2 (AST.:<:) ) )
1601 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1602 , (gtId , (2, genOperator2 (AST.:>:) ) )
1603 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1604 , (boolOrId , (2, genOperator2 AST.Or ) )
1605 , (boolAndId , (2, genOperator2 AST.And ) )
1606 , (plusId , (2, genOperator2 (AST.:+:) ) )
1607 , (timesId , (2, genTimes ) )
1608 , (negateId , (1, genNegation ) )
1609 , (minusId , (2, genOperator2 (AST.:-:) ) )
1610 , (fromSizedWordId , (1, genFromSizedWord ) )
1611 , (fromIntegerId , (1, genFromInteger ) )
1612 , (resizeWordId , (1, genResize ) )
1613 , (resizeIntId , (1, genResize ) )
1614 , (sizedIntId , (1, genSizedInt ) )
1615 , (smallIntegerId , (1, genFromInteger ) )
1616 , (fstId , (1, genFst ) )
1617 , (sndId , (1, genSnd ) )
1618 , (blockRAMId , (5, genBlockRAM ) )
1619 , (splitId , (1, genSplit ) )
1620 --, (tfvecId , (1, genTFVec ) )
1621 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))