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
137 if nonEmpty then error ("No initial state defined for: " ++ show fname) else return ([],[])
138 ([in_state], [out_state], Just resetval) -> mkStateProcSm (in_state, out_state,resetval)
139 ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
140 ([], [], Nothing) -> return ([],[])
141 (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
142 -- Join the create statements and the (optional) state_proc
143 let statements = concat statementss ++ state_proc
144 -- Create the architecture
145 let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
146 let used_entities = (concat used_entitiess) ++ resbndr
147 return (arch, used_entities)
149 dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
150 -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
151 -- ^ ((Input state variable, output state variable), (statements, used entities))
152 -- newtype unpacking is just a cast
153 dobind (bndr, unpacked@(CoreSyn.Cast packed coercion))
154 | hasStateType packed && not (hasStateType unpacked)
155 = return ((Just bndr, Nothing), ([], []))
156 -- With simplCore, newtype packing is just a cast
157 dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion))
158 | hasStateType packed && not (hasStateType unpacked)
159 = return ((Nothing, Just state), ([], []))
160 -- Without simplCore, newtype packing uses a data constructor
161 dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
163 = return ((Nothing, Just state), ([], []))
164 -- Anything else is handled by mkConcSm
167 return ((Nothing, Nothing), sms)
170 (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
171 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
172 mkStateProcSm (old, new, res) = do
173 let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res
174 type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
175 let type_mark_old = Maybe.fromMaybe
176 (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
178 type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
179 let type_mark_res' = Maybe.fromMaybe
180 (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
182 let type_mark_res = if type_mark_old == type_mark_res' then
185 error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
186 let resvalid = mkVHDLExtId $ varToString res ++ "val"
187 let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
188 let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
189 let res_assign = AST.SigAssign (varToVHDLName old) reswform
190 let blocklabel = mkVHDLBasicId "state"
191 let statelabel = mkVHDLBasicId "stateupdate"
192 let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
193 let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
194 let clk_assign = AST.SigAssign (varToVHDLName old) wform
195 let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
196 let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
197 signature <- getEntity res
198 let entity_id = ent_id signature
199 let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
200 let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
201 let reset_statement = mkComponentInst reslabel entity_id portmaps
202 let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
203 let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
204 let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
205 let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
206 return ([block],[res])
208 -- | Transforms a core binding into a VHDL concurrent statement
210 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
211 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
212 -- ^ The corresponding VHDL concurrent statements and entities
216 -- Ignore Cast expressions, they should not longer have any meaning as long as
217 -- the type works out. Throw away state repacking
218 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
219 | hasStateType to && hasStateType from
221 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
223 -- Simple a = b assignments are just like applications, but without arguments.
224 -- We can't just generate an unconditional assignment here, since b might be a
225 -- top level binding (e.g., a function with no arguments).
226 mkConcSm (bndr, CoreSyn.Var v) =
227 genApplication (Left bndr) v []
229 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
230 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
231 let valargs = get_val_args (Var.varType f) args
232 genApplication (Left bndr) f (map Left valargs)
234 -- A single alt case must be a selector. This means the scrutinee is a simple
235 -- variable, the alternative is a dataalt with a single non-wild binder that
237 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
238 -- Don't generate VHDL for substate extraction
239 | hasStateType bndr = return ([], [])
242 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
243 nonemptysel <- hasNonEmptyType sel_bndr
246 bndrs' <- Monad.filterM hasNonEmptyType bndrs
247 case List.elemIndex sel_bndr bndrs' of
249 htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
250 htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
251 case htypeScrt == htypeBndr of
253 let sel_name = varToVHDLName scrut
254 let sel_expr = AST.PrimName sel_name
255 return ([mkUncondAssign (Left bndr) sel_expr], [])
258 Right (AggrType _ _) -> do
259 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
260 let label = labels!!i
261 let sel_name = mkSelectedName (varToVHDLName scrut) label
262 let sel_expr = AST.PrimName sel_name
263 return ([mkUncondAssign (Left bndr) sel_expr], [])
264 _ -> do -- error $ "DIE!"
265 let sel_name = varToVHDLName scrut
266 let sel_expr = AST.PrimName sel_name
267 return ([mkUncondAssign (Left bndr) sel_expr], [])
268 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
270 -- A selector case that selects a state value, ignore it.
273 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
275 -- Multiple case alt are be conditional assignments and have only wild
276 -- binders in the alts and only variables in the case values and a variable
277 -- for a scrutinee. We check the constructor of the second alt, since the
278 -- first is the default case, if there is any.
280 -- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
281 -- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
282 -- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
283 -- let cond_expr = scrut' AST.:=: altcon
284 -- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
285 -- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
286 -- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
287 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
288 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
289 -- Omit first condition, which is the default
290 altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
291 let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
292 -- Rotate expressions to the left, so that the expression related to the default case is the last
293 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
294 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
296 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
297 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
299 -----------------------------------------------------------------------------
300 -- Functions to generate VHDL for builtin functions
301 -----------------------------------------------------------------------------
303 -- | A function to wrap a builder-like function that expects its arguments to
305 genExprArgs wrap dst func args = do
306 args' <- argsToVHDLExprs args
309 -- | Turn the all lefts into VHDL Expressions.
310 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
311 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
313 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
314 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
315 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
316 ty_maybe <- vhdlTy errmsg expr
319 vhdl_expr <- varToVHDLExpr $ exprToVar expr
320 return $ Just vhdl_expr
321 Nothing -> return Nothing
323 argToVHDLExpr (Right expr) = return $ Just expr
325 -- A function to wrap a builder-like function that generates no component
328 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
329 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
330 genNoInsts wrap dst func args = do
331 concsms <- wrap dst func args
334 -- | A function to wrap a builder-like function that expects its arguments to
337 (dst -> func -> [Var.Var] -> res)
338 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
339 genVarArgs wrap dst func args = wrap dst func args'
341 args' = map exprToVar exprargs
342 -- Check (rather crudely) that all arguments are CoreExprs
343 (exprargs, []) = Either.partitionEithers args
345 -- | A function to wrap a builder-like function that expects its arguments to
348 (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
349 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
350 genLitArgs wrap dst func args = do
351 hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
352 let (exprargs, []) = Either.partitionEithers args
353 -- FIXME: Check if we were passed an CoreSyn.App
354 let litargs = concatMap (getLiterals hscenv) exprargs
355 let args' = map exprToLit litargs
358 -- | A function to wrap a builder-like function that produces an expression
359 -- and expects it to be assigned to the destination.
361 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
362 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
363 genExprRes wrap dst func args = do
364 expr <- wrap dst func args
365 return [mkUncondAssign dst expr]
367 -- | Generate a binary operator application. The first argument should be a
368 -- constructor from the AST.Expr type, e.g. AST.And.
369 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
370 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
371 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
372 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
374 -- | Generate a unary operator application
375 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
376 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
377 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
378 genOperator1' op _ f [arg] = return $ op arg
380 -- | Generate a unary operator application
381 genNegation :: BuiltinBuilder
382 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
383 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
384 genNegation' _ f [arg] = do
385 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
386 let ty = Var.varType arg
387 let (tycon, args) = Type.splitTyConApp ty
388 let name = Name.getOccString (TyCon.tyConName tycon)
390 "SizedInt" -> return $ AST.Neg arg1
391 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
393 -- | Generate a function call from the destination binder, function name and a
394 -- list of expressions (its arguments)
395 genFCall :: Bool -> BuiltinBuilder
396 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
397 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
398 genFCall' switch (Left res) f args = do
399 let fname = varToString f
400 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
401 id <- MonadState.lift tsType $ vectorFunId el_ty fname
402 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
403 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
404 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
406 genFromSizedWord :: BuiltinBuilder
407 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
408 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
409 genFromSizedWord' (Left res) f args@[arg] =
410 return [mkUncondAssign (Left res) arg]
411 -- let fname = varToString f
412 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
413 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
414 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
416 genResize :: BuiltinBuilder
417 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
418 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
419 genResize' (Left res) f [arg] = do {
420 ; let { ty = Var.varType res
421 ; (tycon, args) = Type.splitTyConApp ty
422 ; name = Name.getOccString (TyCon.tyConName tycon)
424 ; len <- case name of
425 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
426 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
427 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
428 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
430 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
432 genTimes :: BuiltinBuilder
433 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
434 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
435 genTimes' (Left res) f [arg1,arg2] = do {
436 ; let { ty = Var.varType res
437 ; (tycon, args) = Type.splitTyConApp ty
438 ; name = Name.getOccString (TyCon.tyConName tycon)
440 ; len <- case name of
441 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
442 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
443 "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
444 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
447 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
448 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
450 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
452 -- FIXME: I'm calling genLitArgs which is very specific function,
453 -- which needs to be fixed as well
454 genFromInteger :: BuiltinBuilder
455 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
456 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
457 genFromInteger' (Left res) f lits = do {
458 ; let { ty = Var.varType res
459 ; (tycon, args) = Type.splitTyConApp ty
460 ; name = Name.getOccString (TyCon.tyConName tycon)
462 ; len <- case name of
463 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
464 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
466 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
467 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
469 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
470 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
471 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
475 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
477 genSizedInt :: BuiltinBuilder
478 genSizedInt = genFromInteger
481 -- | Generate a Builder for the builtin datacon TFVec
482 genTFVec :: BuiltinBuilder
483 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
484 -- Generate Assignments for all the binders
485 ; letAssigns <- mapM genBinderAssign letBinders
486 -- Generate assignments for the result (which might be another let binding)
487 ; (resBinders,resAssignments) <- genResAssign letRes
488 -- Get all the Assigned binders
489 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
490 -- Make signal names for all the assigned binders
491 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
492 -- Assign all the signals to the resulting vector
493 ; let { vecsigns = mkAggregateSignal sigs
494 ; vecassign = mkUncondAssign (Left res) vecsigns
496 -- Generate all the signal declaration for the assigned binders
497 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
498 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
499 -- Setup the VHDL Block
500 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
501 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
503 -- Return the block statement coressponding to the TFVec literal
504 ; return $ [AST.CSBSm block]
507 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
508 -- For now we only translate applications
509 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
510 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
511 let valargs = get_val_args (Var.varType f) args
512 apps <- genApplication (Left bndr) f (map Left valargs)
513 return (Just bndr, apps)
514 genBinderAssign _ = return (Nothing,[])
515 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
516 genResAssign app@(CoreSyn.App _ letexpr) = do
518 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
519 letapps <- mapM genBinderAssign letbndrs
520 let bndrs = Maybe.catMaybes (map fst letapps)
521 let app = (map snd letapps)
522 (vars, apps) <- genResAssign letres
523 return ((bndrs ++ vars),((concat app) ++ apps))
524 otherwise -> return ([],[])
525 genResAssign _ = return ([],[])
527 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
528 ; let { elems = reduceCoreListToHsList app
529 -- Make signal names for all the binders
530 ; binders = map (\expr -> case expr of
532 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
533 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
535 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
536 -- Assign all the signals to the resulting vector
537 ; let { vecsigns = mkAggregateSignal sigs
538 ; vecassign = mkUncondAssign (Left res) vecsigns
539 -- Setup the VHDL Block
540 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
541 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
543 -- Return the block statement coressponding to the TFVec literal
544 ; return $ [AST.CSBSm block]
547 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
549 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
551 -- | Generate a generate statement for the builtin function "map"
552 genMap :: BuiltinBuilder
553 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
554 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
555 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
556 -- we must index it (which we couldn't if it was a VHDL Expr, since only
557 -- VHDLNames can be indexed).
558 -- Setup the generate scheme
559 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
560 -- TODO: Use something better than varToString
561 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
562 ; n_id = mkVHDLBasicId "n"
563 ; n_expr = idToVHDLExpr n_id
564 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
565 ; genScheme = AST.ForGn n_id range
566 -- Create the content of the generate statement: Applying the mapped_f to
567 -- each of the elements in arg, storing to each element in res
568 ; resname = mkIndexedName (varToVHDLName res) n_expr
569 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
570 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
571 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
573 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
574 -- Return the generate statement
575 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
578 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
580 genZipWith :: BuiltinBuilder
581 genZipWith = genVarArgs genZipWith'
582 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
583 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
584 -- Setup the generate scheme
585 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
586 -- TODO: Use something better than varToString
587 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
588 ; n_id = mkVHDLBasicId "n"
589 ; n_expr = idToVHDLExpr n_id
590 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
591 ; genScheme = AST.ForGn n_id range
592 -- Create the content of the generate statement: Applying the zipped_f to
593 -- each of the elements in arg1 and arg2, storing to each element in res
594 ; resname = mkIndexedName (varToVHDLName res) n_expr
595 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
596 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
598 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
599 -- Return the generate functions
600 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
603 genFoldl :: BuiltinBuilder
604 genFoldl = genFold True
606 genFoldr :: BuiltinBuilder
607 genFoldr = genFold False
609 genFold :: Bool -> BuiltinBuilder
610 genFold left = genVarArgs (genFold' left)
612 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
613 genFold' left res f args@[folded_f , start ,vec]= do
614 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
615 genFold'' len left res f args
617 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
618 -- Special case for an empty input vector, just assign start to res
619 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
620 arg <- MonadState.lift tsType $ varToVHDLExpr start
621 return ([mkUncondAssign (Left res) arg], [])
623 genFold'' len left (Left res) f [folded_f, start, vec] = do
625 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
626 -- An expression for len-1
627 let len_min_expr = (AST.PrimLit $ show (len-1))
628 -- evec is (TFVec n), so it still needs an element type
629 let (nvec, _) = Type.splitAppTy (Var.varType vec)
630 -- Put the type of the start value in nvec, this will be the type of our
632 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
633 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
634 -- TODO: Handle Nothing
635 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
636 -- Setup the generate scheme
637 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
638 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
639 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
640 else AST.DownRange len_min_expr (AST.PrimLit "0")
641 let gen_scheme = AST.ForGn n_id gen_range
642 -- Make the intermediate vector
643 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
644 -- Create the generate statement
645 cells' <- sequence [genFirstCell, genOtherCell]
646 let (cells, useds) = unzip cells'
647 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
648 -- Assign tmp[len-1] or tmp[0] to res
649 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
650 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
651 (mkIndexedName tmp_name (AST.PrimLit "0")))
652 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
653 return ([AST.CSBSm block], concat useds)
655 -- An id for the counter
656 n_id = mkVHDLBasicId "n"
657 n_cur = idToVHDLExpr n_id
658 -- An expression for previous n
659 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
660 else (n_cur AST.:+: (AST.PrimLit "1"))
661 -- An id for the tmp result vector
662 tmp_id = mkVHDLBasicId "tmp"
663 tmp_name = AST.NSimple tmp_id
664 -- Generate parts of the fold
665 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
667 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
668 let cond_label = mkVHDLExtId "firstcell"
669 -- if n == 0 or n == len-1
670 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
671 else (AST.PrimLit $ show (len-1)))
672 -- Output to tmp[current n]
673 let resname = mkIndexedName tmp_name n_cur
675 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
676 -- Input from vec[current n]
677 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
678 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
679 [Right argexpr1, Right argexpr2]
681 [Right argexpr2, Right argexpr1]
683 -- Return the conditional generate part
684 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
687 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
688 let cond_label = mkVHDLExtId "othercell"
689 -- if n > 0 or n < len-1
690 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
691 else (AST.PrimLit $ show (len-1)))
692 -- Output to tmp[current n]
693 let resname = mkIndexedName tmp_name n_cur
694 -- Input from tmp[previous n]
695 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
696 -- Input from vec[current n]
697 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
698 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
699 [Right argexpr1, Right argexpr2]
701 [Right argexpr2, Right argexpr1]
703 -- Return the conditional generate part
704 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
706 -- | Generate a generate statement for the builtin function "zip"
707 genZip :: BuiltinBuilder
708 genZip = genNoInsts $ genVarArgs genZip'
709 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
710 genZip' (Left res) f args@[arg1, arg2] = do {
711 -- Setup the generate scheme
712 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
713 -- TODO: Use something better than varToString
714 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
715 ; n_id = mkVHDLBasicId "n"
716 ; n_expr = idToVHDLExpr n_id
717 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
718 ; genScheme = AST.ForGn n_id range
719 ; resname' = mkIndexedName (varToVHDLName res) n_expr
720 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
721 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
723 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
724 ; let { resnameA = mkSelectedName resname' (labels!!0)
725 ; resnameB = mkSelectedName resname' (labels!!1)
726 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
727 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
729 -- Return the generate functions
730 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
733 -- | Generate a generate statement for the builtin function "fst"
734 genFst :: BuiltinBuilder
735 genFst = genNoInsts $ genVarArgs genFst'
736 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
737 genFst' (Left res) f args@[arg] = do {
738 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
739 ; let { argexpr' = varToVHDLName arg
740 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
741 ; assign = mkUncondAssign (Left res) argexprA
743 -- Return the generate functions
747 -- | Generate a generate statement for the builtin function "snd"
748 genSnd :: BuiltinBuilder
749 genSnd = genNoInsts $ genVarArgs genSnd'
750 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
751 genSnd' (Left res) f args@[arg] = do {
752 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
753 ; let { argexpr' = varToVHDLName arg
754 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
755 ; assign = mkUncondAssign (Left res) argexprB
757 -- Return the generate functions
761 -- | Generate a generate statement for the builtin function "unzip"
762 genUnzip :: BuiltinBuilder
763 genUnzip = genNoInsts $ genVarArgs genUnzip'
764 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
765 genUnzip' (Left res) f args@[arg] = do
766 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
767 htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
768 -- Prepare a unconditional assignment, for the case when either part
769 -- of the unzip is a state variable, which will disappear in the
770 -- resulting VHDL, making the the unzip no longer required.
772 -- A normal vector containing two-tuples
773 VecType _ (AggrType _ [_, _]) -> do {
774 -- Setup the generate scheme
775 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
776 -- TODO: Use something better than varToString
777 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
778 ; n_id = mkVHDLBasicId "n"
779 ; n_expr = idToVHDLExpr n_id
780 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
781 ; genScheme = AST.ForGn n_id range
782 ; resname' = varToVHDLName res
783 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
785 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
786 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
787 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
788 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
789 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
790 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
791 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
792 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
794 -- Return the generate functions
795 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
797 -- Both elements of the tuple were state, so they've disappeared. No
798 -- need to do anything
799 VecType _ (AggrType _ []) -> return []
800 -- A vector containing aggregates with more than two elements?
801 VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
802 -- One of the elements of the tuple was state, so there won't be a
803 -- tuple (record) in the VHDL output. We can just do a plain
806 argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
807 return [mkUncondAssign (Left res) argexpr]
808 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
810 genCopy :: BuiltinBuilder
811 genCopy = genNoInsts $ genVarArgs genCopy'
812 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
813 genCopy' (Left res) f args@[arg] =
815 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
816 (AST.PrimName (varToVHDLName arg))]
817 out_assign = mkUncondAssign (Left res) resExpr
821 genConcat :: BuiltinBuilder
822 genConcat = genNoInsts $ genVarArgs genConcat'
823 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
824 genConcat' (Left res) f args@[arg] = do {
825 -- Setup the generate scheme
826 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
827 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
828 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
829 -- TODO: Use something better than varToString
830 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
831 ; n_id = mkVHDLBasicId "n"
832 ; n_expr = idToVHDLExpr n_id
833 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
834 ; genScheme = AST.ForGn n_id range
835 -- Create the content of the generate statement: Applying the mapped_f to
836 -- each of the elements in arg, storing to each element in res
837 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
838 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
839 ; resname = vecSlice fromRange toRange
840 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
841 ; out_assign = mkUncondAssign (Right resname) argexpr
843 -- Return the generate statement
844 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
847 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
848 (AST.ToRange init last))
850 genIteraten :: BuiltinBuilder
851 genIteraten dst f args = genIterate dst f (tail args)
853 genIterate :: BuiltinBuilder
854 genIterate = genIterateOrGenerate True
856 genGeneraten :: BuiltinBuilder
857 genGeneraten dst f args = genGenerate dst f (tail args)
859 genGenerate :: BuiltinBuilder
860 genGenerate = genIterateOrGenerate False
862 genIterateOrGenerate :: Bool -> BuiltinBuilder
863 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
865 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
866 genIterateOrGenerate' iter (Left res) f args = do
867 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
868 genIterateOrGenerate'' len iter (Left res) f args
870 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
871 -- Special case for an empty input vector, just assign start to res
872 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
874 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
876 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
877 -- An expression for len-1
878 let len_min_expr = (AST.PrimLit $ show (len-1))
879 -- -- evec is (TFVec n), so it still needs an element type
880 -- let (nvec, _) = splitAppTy (Var.varType vec)
881 -- -- Put the type of the start value in nvec, this will be the type of our
882 -- -- temporary vector
883 let tmp_ty = Var.varType res
884 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
885 -- TODO: Handle Nothing
886 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
887 -- Setup the generate scheme
888 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
889 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
890 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
891 let gen_scheme = AST.ForGn n_id gen_range
892 -- Make the intermediate vector
893 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
894 -- Create the generate statement
895 cells' <- sequence [genFirstCell, genOtherCell]
896 let (cells, useds) = unzip cells'
897 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
898 -- Assign tmp[len-1] or tmp[0] to res
899 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
900 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
901 return ([AST.CSBSm block], concat useds)
903 -- An id for the counter
904 n_id = mkVHDLBasicId "n"
905 n_cur = idToVHDLExpr n_id
906 -- An expression for previous n
907 n_prev = n_cur AST.:-: (AST.PrimLit "1")
908 -- An id for the tmp result vector
909 tmp_id = mkVHDLBasicId "tmp"
910 tmp_name = AST.NSimple tmp_id
911 -- Generate parts of the fold
912 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
914 let cond_label = mkVHDLExtId "firstcell"
915 -- if n == 0 or n == len-1
916 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
917 -- Output to tmp[current n]
918 let resname = mkIndexedName tmp_name n_cur
920 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
921 let startassign = mkUncondAssign (Right resname) argexpr
922 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
923 -- Return the conditional generate part
924 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
932 let cond_label = mkVHDLExtId "othercell"
933 -- if n > 0 or n < len-1
934 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
935 -- Output to tmp[current n]
936 let resname = mkIndexedName tmp_name n_cur
937 -- Input from tmp[previous n]
938 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
939 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
940 -- Return the conditional generate part
941 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
943 genBlockRAM :: BuiltinBuilder
944 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
946 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
947 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
949 let (tup,data_out) = Type.splitAppTy (Var.varType res)
950 let (tup',ramvec) = Type.splitAppTy tup
951 let Just realram = Type.coreView ramvec
952 let Just (tycon, types) = Type.splitTyConApp_maybe realram
953 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
954 -- Make the intermediate vector
955 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
956 -- Get the data_out name
957 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
958 let resname = varToVHDLName res
959 -- let resname = mkSelectedName resname' (reslabels!!0)
960 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
961 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
962 let assign = mkUncondAssign (Right resname) argexpr
963 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
964 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
965 return [AST.CSBSm block]
967 ram_id = mkVHDLBasicId "ram"
968 mkUpdateProcSm :: AST.ConcSm
969 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
971 proclabel = mkVHDLBasicId "updateRAM"
972 rising_edge = mkVHDLBasicId "rising_edge"
973 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
974 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
975 wform = AST.Wform [AST.WformElem data_in Nothing]
976 ramassign = AST.SigAssign ramloc wform
977 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
978 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
980 genSplit :: BuiltinBuilder
981 genSplit = genNoInsts $ genVarArgs genSplit'
983 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
984 genSplit' (Left res) f args@[vecIn] = do {
985 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
986 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
987 ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
988 ; halflen = round ((fromIntegral len) / 2)
989 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
990 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
991 ; resname = varToVHDLName res
992 ; resnameL = mkSelectedName resname (labels!!0)
993 ; resnameR = mkSelectedName resname (labels!!1)
994 ; argexprL = vhdlNameToVHDLExpr rangeL
995 ; argexprR = vhdlNameToVHDLExpr rangeR
996 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
997 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
998 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1000 ; return [AST.CSBSm block]
1003 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1004 (AST.ToRange init last))
1005 -----------------------------------------------------------------------------
1006 -- Function to generate VHDL for applications
1007 -----------------------------------------------------------------------------
1009 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
1010 -> CoreSyn.CoreBndr -- ^ The function to apply
1011 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
1012 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1013 -- ^ The corresponding VHDL concurrent statements and entities
1015 genApplication dst f args = do
1016 nonemptydst <- case dst of
1017 Left bndr -> hasNonEmptyType bndr
1018 Right _ -> return True
1021 if Var.isGlobalId f then
1022 case Var.idDetails f of
1023 IdInfo.DataConWorkId dc -> case dst of
1024 -- It's a datacon. Create a record from its arguments.
1026 -- We have the bndr, so we can get at the type
1027 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1028 let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
1031 [arg'] <- argsToVHDLExprs [arg]
1032 return ([mkUncondAssign dst arg'], [])
1035 Right (AggrType _ _) -> do
1036 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
1037 args' <- argsToVHDLExprs argsNostate
1038 return (zipWith mkassign labels args', [])
1040 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1041 mkassign label arg =
1042 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1043 mkUncondAssign (Right sel_name) arg
1044 _ -> do -- error $ "DIE!"
1045 args' <- argsToVHDLExprs argsNostate
1046 return ([mkUncondAssign dst (head args')], [])
1047 Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1048 IdInfo.DataConWrapId dc -> case dst of
1049 -- It's a datacon. Create a record from its arguments.
1051 case (Map.lookup (varToString f) globalNameTable) of
1052 Just (arg_count, builder) ->
1053 if length args == arg_count then
1056 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1057 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1058 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1060 -- It's a global value imported from elsewhere. These can be builtin
1061 -- functions. Look up the function name in the name table and execute
1062 -- the associated builder if there is any and the argument count matches
1063 -- (this should always be the case if it typechecks, but just to be
1065 case (Map.lookup (varToString f) globalNameTable) of
1066 Just (arg_count, builder) ->
1067 if length args == arg_count then
1070 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1072 top <- isTopLevelBinder f
1075 -- Local binder that references a top level binding. Generate a
1076 -- component instantiation.
1077 signature <- getEntity f
1078 args' <- argsToVHDLExprs args
1079 let entity_id = ent_id signature
1080 -- TODO: Using show here isn't really pretty, but we'll need some
1081 -- unique-ish value...
1082 let label = "comp_ins_" ++ (either show prettyShow) dst
1083 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1084 return ([mkComponentInst label entity_id portmaps], [f])
1086 -- Not a top level binder, so this must be a local variable reference.
1087 -- It should have a representable type (and thus, no arguments) and a
1088 -- signal should be generated for it. Just generate an unconditional
1090 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1091 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1092 -- return $ ([mkUncondAssign dst f'], [])
1093 do errtype <- case dst of
1095 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1097 Right vhd -> return $ show vhd
1098 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1099 IdInfo.ClassOpId cls ->
1100 -- FIXME: Not looking for what instance this class op is called for
1101 -- Is quite stupid of course.
1102 case (Map.lookup (varToString f) globalNameTable) of
1103 Just (arg_count, builder) ->
1104 if length args == arg_count then
1107 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1108 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1109 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1111 top <- isTopLevelBinder f
1114 -- Local binder that references a top level binding. Generate a
1115 -- component instantiation.
1116 signature <- getEntity f
1117 args' <- argsToVHDLExprs args
1118 let entity_id = ent_id signature
1119 -- TODO: Using show here isn't really pretty, but we'll need some
1120 -- unique-ish value...
1121 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1122 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1123 return ([mkComponentInst label entity_id portmaps], [f])
1125 -- Not a top level binder, so this must be a local variable reference.
1126 -- It should have a representable type (and thus, no arguments) and a
1127 -- signal should be generated for it. Just generate an unconditional
1129 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1130 return ([mkUncondAssign dst f'], [])
1131 else -- Destination has empty type, don't generate anything
1133 -----------------------------------------------------------------------------
1134 -- Functions to generate functions dealing with vectors.
1135 -----------------------------------------------------------------------------
1137 -- Returns the VHDLId of the vector function with the given name for the given
1138 -- element type. Generates -- this function if needed.
1139 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1140 vectorFunId el_ty fname = do
1141 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1142 -- TODO: Handle the Nothing case?
1143 elemTM_maybe <- vhdlTy error_msg el_ty
1144 let elemTM = Maybe.fromMaybe
1145 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1147 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1148 -- the VHDLState or something.
1149 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1150 typefuns <- MonadState.get tsTypeFuns
1151 el_htype <- mkHType error_msg el_ty
1152 case Map.lookup (UVecType el_htype, fname) typefuns of
1153 -- Function already generated, just return it
1154 Just (id, _) -> return id
1155 -- Function not generated yet, generate it
1157 let functions = genUnconsVectorFuns elemTM vectorTM
1158 case lookup fname functions of
1160 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1161 mapM_ (vectorFunId el_ty) (snd body)
1163 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1165 function_id = mkVHDLExtId fname
1167 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1168 -> AST.TypeMark -- ^ type of the vector
1169 -> [(String, (AST.SubProgBody, [String]))]
1170 genUnconsVectorFuns elemTM vectorTM =
1171 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1172 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1173 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1174 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1175 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1176 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1177 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1178 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1179 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1180 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1181 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1182 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1183 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1184 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1185 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1186 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1187 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1188 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1189 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1190 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1191 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1194 ixPar = AST.unsafeVHDLBasicId "ix"
1195 vecPar = AST.unsafeVHDLBasicId "vec"
1196 vec1Par = AST.unsafeVHDLBasicId "vec1"
1197 vec2Par = AST.unsafeVHDLBasicId "vec2"
1198 nPar = AST.unsafeVHDLBasicId "n"
1199 leftPar = AST.unsafeVHDLBasicId "nLeft"
1200 rightPar = AST.unsafeVHDLBasicId "nRight"
1201 iId = AST.unsafeVHDLBasicId "i"
1203 aPar = AST.unsafeVHDLBasicId "a"
1204 fPar = AST.unsafeVHDLBasicId "f"
1205 sPar = AST.unsafeVHDLBasicId "s"
1206 resId = AST.unsafeVHDLBasicId "res"
1207 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1208 AST.IfaceVarDec ixPar unsignedTM] elemTM
1209 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1210 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1211 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1212 , AST.IfaceVarDec iPar unsignedTM
1213 , AST.IfaceVarDec aPar elemTM
1215 -- variable res : fsvec_x (0 to vec'length-1);
1218 (AST.SubtypeIn vectorTM
1219 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1220 [AST.ToRange (AST.PrimLit "0")
1221 (AST.PrimName (AST.NAttribute $
1222 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1223 (AST.PrimLit "1")) ]))
1225 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1226 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1227 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1228 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1229 vecSlice init last = AST.PrimName (AST.NSlice
1231 (AST.NSimple vecPar)
1232 (AST.ToRange init last)))
1233 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1234 -- return vec(vec'length-1);
1235 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1236 (AST.NSimple vecPar)
1237 [AST.PrimName (AST.NAttribute $
1238 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1239 AST.:-: AST.PrimLit "1"])))
1240 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1241 -- variable res : fsvec_x (0 to vec'length-2);
1244 (AST.SubtypeIn vectorTM
1245 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1246 [AST.ToRange (AST.PrimLit "0")
1247 (AST.PrimName (AST.NAttribute $
1248 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1249 (AST.PrimLit "2")) ]))
1251 -- resAST.:= vec(0 to vec'length-2)
1252 initExpr = AST.NSimple resId AST.:= (vecSlice
1254 (AST.PrimName (AST.NAttribute $
1255 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1256 AST.:-: AST.PrimLit "2"))
1257 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1258 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1259 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1260 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1261 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1263 (Just $ AST.Else [minimumExprRet])
1264 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1265 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1266 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1267 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1268 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1269 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1270 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1271 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1274 (AST.SubtypeIn vectorTM
1275 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1276 [AST.ToRange (AST.PrimLit "0")
1278 (AST.PrimLit "1")) ]))
1280 -- res AST.:= vec(0 to n-1)
1281 takeExpr = AST.NSimple resId AST.:=
1282 (vecSlice (AST.PrimLit "0")
1283 (minLength AST.:-: AST.PrimLit "1"))
1284 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1285 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1286 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1287 -- variable res : fsvec_x (0 to vec'length-n-1);
1290 (AST.SubtypeIn vectorTM
1291 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1292 [AST.ToRange (AST.PrimLit "0")
1293 (AST.PrimName (AST.NAttribute $
1294 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1295 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1297 -- res AST.:= vec(n to vec'length-1)
1298 dropExpr = AST.NSimple resId AST.:= (vecSlice
1299 (AST.PrimName $ AST.NSimple nPar)
1300 (AST.PrimName (AST.NAttribute $
1301 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1302 AST.:-: AST.PrimLit "1"))
1303 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1304 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1305 AST.IfaceVarDec vecPar vectorTM] vectorTM
1306 -- variable res : fsvec_x (0 to vec'length);
1309 (AST.SubtypeIn vectorTM
1310 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1311 [AST.ToRange (AST.PrimLit "0")
1312 (AST.PrimName (AST.NAttribute $
1313 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1315 plusgtExpr = AST.NSimple resId AST.:=
1316 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1317 (AST.PrimName $ AST.NSimple vecPar))
1318 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1319 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1322 (AST.SubtypeIn vectorTM
1323 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1324 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1326 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1327 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1329 -- variable res : fsvec_x (0 to 0) := (others => a);
1332 (AST.SubtypeIn vectorTM
1333 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1334 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1335 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1336 (AST.PrimName $ AST.NSimple aPar)])
1337 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1338 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1339 AST.IfaceVarDec aPar elemTM ] vectorTM
1340 -- variable res : fsvec_x (0 to n-1) := (others => a);
1343 (AST.SubtypeIn vectorTM
1344 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1345 [AST.ToRange (AST.PrimLit "0")
1346 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1347 (AST.PrimLit "1")) ]))
1348 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1349 (AST.PrimName $ AST.NSimple aPar)])
1351 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1352 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1353 AST.IfaceVarDec sPar naturalTM,
1354 AST.IfaceVarDec nPar naturalTM,
1355 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1356 -- variable res : fsvec_x (0 to n-1);
1359 (AST.SubtypeIn vectorTM
1360 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1361 [AST.ToRange (AST.PrimLit "0")
1362 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1363 (AST.PrimLit "1")) ])
1366 -- for i res'range loop
1367 -- res(i) := vec(f+i*s);
1369 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1370 -- res(i) := vec(f+i*s);
1371 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1372 (AST.PrimName (AST.NSimple iId) AST.:*:
1373 AST.PrimName (AST.NSimple sPar)) in
1374 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1375 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1377 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1378 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1379 AST.IfaceVarDec aPar elemTM] vectorTM
1380 -- variable res : fsvec_x (0 to vec'length);
1383 (AST.SubtypeIn vectorTM
1384 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1385 [AST.ToRange (AST.PrimLit "0")
1386 (AST.PrimName (AST.NAttribute $
1387 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1389 ltplusExpr = AST.NSimple resId AST.:=
1390 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1391 (AST.PrimName $ AST.NSimple aPar))
1392 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1393 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1394 AST.IfaceVarDec vec2Par vectorTM]
1396 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1399 (AST.SubtypeIn vectorTM
1400 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1401 [AST.ToRange (AST.PrimLit "0")
1402 (AST.PrimName (AST.NAttribute $
1403 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1404 AST.PrimName (AST.NAttribute $
1405 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1408 plusplusExpr = AST.NSimple resId AST.:=
1409 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1410 (AST.PrimName $ AST.NSimple vec2Par))
1411 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1412 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1413 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1414 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1415 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1416 AST.IfaceVarDec aPar elemTM ] vectorTM
1417 -- variable res : fsvec_x (0 to vec'length-1);
1420 (AST.SubtypeIn vectorTM
1421 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1422 [AST.ToRange (AST.PrimLit "0")
1423 (AST.PrimName (AST.NAttribute $
1424 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1425 (AST.PrimLit "1")) ]))
1427 -- res := a & init(vec)
1428 shiftlExpr = AST.NSimple resId AST.:=
1429 (AST.PrimName (AST.NSimple aPar) AST.:&:
1430 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1431 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1432 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1433 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1434 AST.IfaceVarDec aPar elemTM ] vectorTM
1435 -- variable res : fsvec_x (0 to vec'length-1);
1438 (AST.SubtypeIn vectorTM
1439 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1440 [AST.ToRange (AST.PrimLit "0")
1441 (AST.PrimName (AST.NAttribute $
1442 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1443 (AST.PrimLit "1")) ]))
1445 -- res := tail(vec) & a
1446 shiftrExpr = AST.NSimple resId AST.:=
1447 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1448 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1449 (AST.PrimName (AST.NSimple aPar)))
1451 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1452 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1453 -- return vec'length = 0
1454 nullExpr = AST.ReturnSm (Just $
1455 AST.PrimName (AST.NAttribute $
1456 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1458 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1459 -- variable res : fsvec_x (0 to vec'length-1);
1462 (AST.SubtypeIn vectorTM
1463 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1464 [AST.ToRange (AST.PrimLit "0")
1465 (AST.PrimName (AST.NAttribute $
1466 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1467 (AST.PrimLit "1")) ]))
1469 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1470 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1471 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1472 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1474 (Just $ AST.Else [rotlExprRet])
1476 AST.NSimple resId AST.:=
1477 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1478 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1479 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1480 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1481 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1482 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1483 -- variable res : fsvec_x (0 to vec'length-1);
1486 (AST.SubtypeIn vectorTM
1487 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1488 [AST.ToRange (AST.PrimLit "0")
1489 (AST.PrimName (AST.NAttribute $
1490 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1491 (AST.PrimLit "1")) ]))
1493 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1494 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1495 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1496 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1498 (Just $ AST.Else [rotrExprRet])
1500 AST.NSimple resId AST.:=
1501 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1502 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1503 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1504 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1505 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1506 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1509 (AST.SubtypeIn vectorTM
1510 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1511 [AST.ToRange (AST.PrimLit "0")
1512 (AST.PrimName (AST.NAttribute $
1513 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1514 (AST.PrimLit "1")) ]))
1516 -- for i in 0 to res'range loop
1517 -- res(vec'length-i-1) := vec(i);
1520 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1521 -- res(vec'length-i-1) := vec(i);
1522 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1523 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1524 [AST.PrimName $ AST.NSimple iId]))
1525 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1526 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1527 AST.PrimName (AST.NSimple iId) AST.:-:
1530 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1533 -----------------------------------------------------------------------------
1534 -- A table of builtin functions
1535 -----------------------------------------------------------------------------
1537 -- A function that generates VHDL for a builtin function
1538 type BuiltinBuilder =
1539 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1540 -> CoreSyn.CoreBndr -- ^ The function called
1541 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1542 -- dictionary arguments).
1543 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1544 -- ^ The corresponding VHDL concurrent statements and entities
1547 -- A map of a builtin function to VHDL function builder
1548 type NameTable = Map.Map String (Int, BuiltinBuilder )
1550 -- | The builtin functions we support. Maps a name to an argument count and a
1551 -- builder function.
1552 globalNameTable :: NameTable
1553 globalNameTable = Map.fromList
1554 [ (exId , (2, genFCall True ) )
1555 , (replaceId , (3, genFCall False ) )
1556 , (headId , (1, genFCall True ) )
1557 , (lastId , (1, genFCall True ) )
1558 , (tailId , (1, genFCall False ) )
1559 , (initId , (1, genFCall False ) )
1560 , (takeId , (2, genFCall False ) )
1561 , (dropId , (2, genFCall False ) )
1562 , (selId , (4, genFCall False ) )
1563 , (plusgtId , (2, genFCall False ) )
1564 , (ltplusId , (2, genFCall False ) )
1565 , (plusplusId , (2, genFCall False ) )
1566 , (mapId , (2, genMap ) )
1567 , (zipWithId , (3, genZipWith ) )
1568 , (foldlId , (3, genFoldl ) )
1569 , (foldrId , (3, genFoldr ) )
1570 , (zipId , (2, genZip ) )
1571 , (unzipId , (1, genUnzip ) )
1572 , (shiftlId , (2, genFCall False ) )
1573 , (shiftrId , (2, genFCall False ) )
1574 , (rotlId , (1, genFCall False ) )
1575 , (rotrId , (1, genFCall False ) )
1576 , (concatId , (1, genConcat ) )
1577 , (reverseId , (1, genFCall False ) )
1578 , (iteratenId , (3, genIteraten ) )
1579 , (iterateId , (2, genIterate ) )
1580 , (generatenId , (3, genGeneraten ) )
1581 , (generateId , (2, genGenerate ) )
1582 , (emptyId , (0, genFCall False ) )
1583 , (singletonId , (1, genFCall False ) )
1584 , (copynId , (2, genFCall False ) )
1585 , (copyId , (1, genCopy ) )
1586 , (lengthTId , (1, genFCall False ) )
1587 , (nullId , (1, genFCall False ) )
1588 , (hwxorId , (2, genOperator2 AST.Xor ) )
1589 , (hwandId , (2, genOperator2 AST.And ) )
1590 , (hworId , (2, genOperator2 AST.Or ) )
1591 , (hwnotId , (1, genOperator1 AST.Not ) )
1592 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1593 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1594 , (ltId , (2, genOperator2 (AST.:<:) ) )
1595 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1596 , (gtId , (2, genOperator2 (AST.:>:) ) )
1597 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1598 , (boolOrId , (2, genOperator2 AST.Or ) )
1599 , (boolAndId , (2, genOperator2 AST.And ) )
1600 , (plusId , (2, genOperator2 (AST.:+:) ) )
1601 , (timesId , (2, genTimes ) )
1602 , (negateId , (1, genNegation ) )
1603 , (minusId , (2, genOperator2 (AST.:-:) ) )
1604 , (fromSizedWordId , (1, genFromSizedWord ) )
1605 , (fromIntegerId , (1, genFromInteger ) )
1606 , (resizeWordId , (1, genResize ) )
1607 , (resizeIntId , (1, genResize ) )
1608 , (sizedIntId , (1, genSizedInt ) )
1609 , (smallIntegerId , (1, genFromInteger ) )
1610 , (fstId , (1, genFst ) )
1611 , (sndId , (1, genSnd ) )
1612 , (blockRAMId , (5, genBlockRAM ) )
1613 , (splitId , (1, genSplit ) )
1614 --, (tfvecId , (1, genTFVec ) )
1615 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))