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 False 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 False 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 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 = genCoreArgs $ \dst func args -> let
346 args' = map exprToVar args
350 -- | A function to wrap a builder-like function that expects its arguments to
351 -- be core expressions.
353 (dst -> func -> [CoreSyn.CoreExpr] -> res)
354 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
355 genCoreArgs wrap dst func args = wrap dst func args'
357 -- Check (rather crudely) that all arguments are CoreExprs
358 args' = case Either.partitionEithers args of
359 (exprargs, []) -> exprargs
360 (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
362 -- | A function to wrap a builder-like function that expects its arguments to
365 (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
366 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
367 genLitArgs wrap dst func args = do
368 hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
369 let (exprargs, []) = Either.partitionEithers args
370 -- FIXME: Check if we were passed an CoreSyn.App
371 let litargs = concatMap (getLiterals hscenv) exprargs
372 let args' = map exprToLit litargs
375 -- | A function to wrap a builder-like function that produces an expression
376 -- and expects it to be assigned to the destination.
378 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
379 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
380 genExprRes wrap dst func args = do
381 expr <- wrap dst func args
382 return [mkUncondAssign dst expr]
384 -- | Generate a binary operator application. The first argument should be a
385 -- constructor from the AST.Expr type, e.g. AST.And.
386 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
387 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
388 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
389 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
391 -- | Generate a unary operator application
392 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
393 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
394 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
395 genOperator1' op _ f [arg] = return $ op arg
397 -- | Generate a unary operator application
398 genNegation :: BuiltinBuilder
399 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
400 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
401 genNegation' _ f [arg] = do
402 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
403 let ty = Var.varType arg
404 let (tycon, args) = Type.splitTyConApp ty
405 let name = Name.getOccString (TyCon.tyConName tycon)
407 "SizedInt" -> return $ AST.Neg arg1
408 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
410 -- | Generate a function call from the destination binder, function name and a
411 -- list of expressions (its arguments)
412 genFCall :: Bool -> BuiltinBuilder
413 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
414 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
415 genFCall' switch (Left res) f args = do
416 let fname = varToString f
417 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
418 id <- MonadState.lift tsType $ vectorFunId el_ty fname
419 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
420 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
421 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
423 genFromSizedWord :: BuiltinBuilder
424 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
425 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
426 genFromSizedWord' (Left res) f args@[arg] =
427 return [mkUncondAssign (Left res) arg]
428 -- let fname = varToString f
429 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
430 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
431 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
433 genFromRangedWord :: BuiltinBuilder
434 genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
435 genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
436 genFromRangedWord' (Left res) f [arg] = do {
437 ; let { ty = Var.varType res
438 ; (tycon, args) = Type.splitTyConApp ty
439 ; name = Name.getOccString (TyCon.tyConName tycon)
441 ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
442 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
443 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
445 genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
447 genResize :: BuiltinBuilder
448 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
449 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
450 genResize' (Left res) f [arg] = do {
451 ; let { ty = Var.varType res
452 ; (tycon, args) = Type.splitTyConApp ty
453 ; name = Name.getOccString (TyCon.tyConName tycon)
455 ; len <- case name of
456 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
457 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
458 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
459 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
461 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
463 genTimes :: BuiltinBuilder
464 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
465 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
466 genTimes' (Left res) f [arg1,arg2] = do {
467 ; let { ty = Var.varType res
468 ; (tycon, args) = Type.splitTyConApp ty
469 ; name = Name.getOccString (TyCon.tyConName tycon)
471 ; len <- case name of
472 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
473 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
474 "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
475 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
478 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
479 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
481 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
483 -- FIXME: I'm calling genLitArgs which is very specific function,
484 -- which needs to be fixed as well
485 genFromInteger :: BuiltinBuilder
486 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
487 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
488 genFromInteger' (Left res) f lits = do {
489 ; let { ty = Var.varType res
490 ; (tycon, args) = Type.splitTyConApp ty
491 ; name = Name.getOccString (TyCon.tyConName tycon)
493 ; len <- case name of
494 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
495 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
497 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
498 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
500 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
501 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
502 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
506 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
508 genSizedInt :: BuiltinBuilder
509 genSizedInt = genFromInteger
512 -- | Generate a Builder for the builtin datacon TFVec
513 genTFVec :: BuiltinBuilder
514 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
515 -- Generate Assignments for all the binders
516 ; letAssigns <- mapM genBinderAssign letBinders
517 -- Generate assignments for the result (which might be another let binding)
518 ; (resBinders,resAssignments) <- genResAssign letRes
519 -- Get all the Assigned binders
520 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
521 -- Make signal names for all the assigned binders
522 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
523 -- Assign all the signals to the resulting vector
524 ; let { vecsigns = mkAggregateSignal sigs
525 ; vecassign = mkUncondAssign (Left res) vecsigns
527 -- Generate all the signal declaration for the assigned binders
528 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
529 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
530 -- Setup the VHDL Block
531 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
532 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
534 -- Return the block statement coressponding to the TFVec literal
535 ; return $ [AST.CSBSm block]
538 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
539 -- For now we only translate applications
540 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
541 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
542 let valargs = get_val_args (Var.varType f) args
543 apps <- genApplication (Left bndr) f (map Left valargs)
544 return (Just bndr, apps)
545 genBinderAssign _ = return (Nothing,[])
546 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
547 genResAssign app@(CoreSyn.App _ letexpr) = do
549 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
550 letapps <- mapM genBinderAssign letbndrs
551 let bndrs = Maybe.catMaybes (map fst letapps)
552 let app = (map snd letapps)
553 (vars, apps) <- genResAssign letres
554 return ((bndrs ++ vars),((concat app) ++ apps))
555 otherwise -> return ([],[])
556 genResAssign _ = return ([],[])
558 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
559 ; let { elems = reduceCoreListToHsList app
560 -- Make signal names for all the binders
561 ; binders = map (\expr -> case expr of
563 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
564 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
566 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
567 -- Assign all the signals to the resulting vector
568 ; let { vecsigns = mkAggregateSignal sigs
569 ; vecassign = mkUncondAssign (Left res) vecsigns
570 -- Setup the VHDL Block
571 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
572 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
574 -- Return the block statement coressponding to the TFVec literal
575 ; return $ [AST.CSBSm block]
578 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
580 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
582 -- | Generate a generate statement for the builtin function "map"
583 genMap :: BuiltinBuilder
584 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
585 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
586 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
587 -- we must index it (which we couldn't if it was a VHDL Expr, since only
588 -- VHDLNames can be indexed).
589 -- Setup the generate scheme
590 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
591 -- TODO: Use something better than varToString
592 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
593 ; n_id = mkVHDLBasicId "n"
594 ; n_expr = idToVHDLExpr n_id
595 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
596 ; genScheme = AST.ForGn n_id range
597 -- Create the content of the generate statement: Applying the mapped_f to
598 -- each of the elements in arg, storing to each element in res
599 ; resname = mkIndexedName (varToVHDLName res) n_expr
600 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
601 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
602 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
604 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
605 -- Return the generate statement
606 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
609 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
611 genZipWith :: BuiltinBuilder
612 genZipWith (Left res) f args@[Left zipped_f, Left (CoreSyn.Var arg1), Left (CoreSyn.Var arg2)] = do {
613 -- Setup the generate scheme
614 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
615 -- TODO: Use something better than varToString
616 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
617 ; n_id = mkVHDLBasicId "n"
618 ; n_expr = idToVHDLExpr n_id
619 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
620 ; genScheme = AST.ForGn n_id range
621 -- Create the content of the generate statement: Applying the zipped_f to
622 -- each of the elements in arg1 and arg2, storing to each element in res
623 ; resname = mkIndexedName (varToVHDLName res) n_expr
624 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
625 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
626 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
627 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
629 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr1, Right argexpr2])
630 -- Return the generate functions
631 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
634 genFoldl :: BuiltinBuilder
635 genFoldl = genFold True
637 genFoldr :: BuiltinBuilder
638 genFoldr = genFold False
640 genFold :: Bool -> BuiltinBuilder
641 genFold left = genVarArgs (genFold' left)
643 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
644 genFold' left res f args@[folded_f , start ,vec]= do
645 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
646 genFold'' len left res f args
648 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
649 -- Special case for an empty input vector, just assign start to res
650 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
651 arg <- MonadState.lift tsType $ varToVHDLExpr start
652 return ([mkUncondAssign (Left res) arg], [])
654 genFold'' len left (Left res) f [folded_f, start, vec] = do
656 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
657 -- An expression for len-1
658 let len_min_expr = (AST.PrimLit $ show (len-1))
659 -- evec is (TFVec n), so it still needs an element type
660 let (nvec, _) = Type.splitAppTy (Var.varType vec)
661 -- Put the type of the start value in nvec, this will be the type of our
663 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
664 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
665 -- TODO: Handle Nothing
666 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
667 -- Setup the generate scheme
668 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
669 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
670 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
671 else AST.DownRange len_min_expr (AST.PrimLit "0")
672 let gen_scheme = AST.ForGn n_id gen_range
673 -- Make the intermediate vector
674 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
675 -- Create the generate statement
676 cells' <- sequence [genFirstCell, genOtherCell]
677 let (cells, useds) = unzip cells'
678 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
679 -- Assign tmp[len-1] or tmp[0] to res
680 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
681 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
682 (mkIndexedName tmp_name (AST.PrimLit "0")))
683 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
684 return ([AST.CSBSm block], concat useds)
686 -- An id for the counter
687 n_id = mkVHDLBasicId "n"
688 n_cur = idToVHDLExpr n_id
689 -- An expression for previous n
690 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
691 else (n_cur AST.:+: (AST.PrimLit "1"))
692 -- An id for the tmp result vector
693 tmp_id = mkVHDLBasicId "tmp"
694 tmp_name = AST.NSimple tmp_id
695 -- Generate parts of the fold
696 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
698 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
699 let cond_label = mkVHDLExtId "firstcell"
700 -- if n == 0 or n == len-1
701 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
702 else (AST.PrimLit $ show (len-1)))
703 -- Output to tmp[current n]
704 let resname = mkIndexedName tmp_name n_cur
706 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
707 -- Input from vec[current n]
708 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
709 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
710 [Right argexpr1, Right argexpr2]
712 [Right argexpr2, Right argexpr1]
714 -- Return the conditional generate part
715 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
718 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
719 let cond_label = mkVHDLExtId "othercell"
720 -- if n > 0 or n < len-1
721 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
722 else (AST.PrimLit $ show (len-1)))
723 -- Output to tmp[current n]
724 let resname = mkIndexedName tmp_name n_cur
725 -- Input from tmp[previous n]
726 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
727 -- Input from vec[current n]
728 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
729 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
730 [Right argexpr1, Right argexpr2]
732 [Right argexpr2, Right argexpr1]
734 -- Return the conditional generate part
735 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
737 -- | Generate a generate statement for the builtin function "zip"
738 genZip :: BuiltinBuilder
739 genZip = genNoInsts $ genVarArgs genZip'
740 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
741 genZip' (Left res) f args@[arg1, arg2] = do {
742 -- Setup the generate scheme
743 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
744 -- TODO: Use something better than varToString
745 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
746 ; n_id = mkVHDLBasicId "n"
747 ; n_expr = idToVHDLExpr n_id
748 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
749 ; genScheme = AST.ForGn n_id range
750 ; resname' = mkIndexedName (varToVHDLName res) n_expr
751 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
752 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
754 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
755 ; let { resnameA = mkSelectedName resname' (labels!!0)
756 ; resnameB = mkSelectedName resname' (labels!!1)
757 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
758 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
760 -- Return the generate functions
761 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
764 -- | Generate a generate statement for the builtin function "fst"
765 genFst :: BuiltinBuilder
766 genFst = genNoInsts $ genVarArgs genFst'
767 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
768 genFst' (Left res) f args@[arg] = do {
769 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
770 ; let { argexpr' = varToVHDLName arg
771 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
772 ; assign = mkUncondAssign (Left res) argexprA
774 -- Return the generate functions
778 -- | Generate a generate statement for the builtin function "snd"
779 genSnd :: BuiltinBuilder
780 genSnd = genNoInsts $ genVarArgs genSnd'
781 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
782 genSnd' (Left res) f args@[arg] = do {
783 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
784 ; let { argexpr' = varToVHDLName arg
785 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
786 ; assign = mkUncondAssign (Left res) argexprB
788 -- Return the generate functions
792 -- | Generate a generate statement for the builtin function "unzip"
793 genUnzip :: BuiltinBuilder
794 genUnzip = genNoInsts $ genVarArgs genUnzip'
795 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
796 genUnzip' (Left res) f args@[arg] = do
797 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
798 htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
799 -- Prepare a unconditional assignment, for the case when either part
800 -- of the unzip is a state variable, which will disappear in the
801 -- resulting VHDL, making the the unzip no longer required.
803 -- A normal vector containing two-tuples
804 VecType _ (AggrType _ [_, _]) -> do {
805 -- Setup the generate scheme
806 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
807 -- TODO: Use something better than varToString
808 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
809 ; n_id = mkVHDLBasicId "n"
810 ; n_expr = idToVHDLExpr n_id
811 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
812 ; genScheme = AST.ForGn n_id range
813 ; resname' = varToVHDLName res
814 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
816 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
817 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
818 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
819 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
820 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
821 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
822 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
823 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
825 -- Return the generate functions
826 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
828 -- Both elements of the tuple were state, so they've disappeared. No
829 -- need to do anything
830 VecType _ (AggrType _ []) -> return []
831 -- A vector containing aggregates with more than two elements?
832 VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
833 -- One of the elements of the tuple was state, so there won't be a
834 -- tuple (record) in the VHDL output. We can just do a plain
837 argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
838 return [mkUncondAssign (Left res) argexpr]
839 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
841 genCopy :: BuiltinBuilder
842 genCopy = genNoInsts genCopy'
843 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm]
844 genCopy' (Left res) f [arg] = do {
845 ; [arg'] <- argsToVHDLExprs [arg]
846 ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
847 ; out_assign = mkUncondAssign (Left res) resExpr
849 ; return [out_assign]
852 genConcat :: BuiltinBuilder
853 genConcat = genNoInsts $ genVarArgs genConcat'
854 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
855 genConcat' (Left res) f args@[arg] = do {
856 -- Setup the generate scheme
857 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
858 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
859 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
860 -- TODO: Use something better than varToString
861 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
862 ; n_id = mkVHDLBasicId "n"
863 ; n_expr = idToVHDLExpr n_id
864 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
865 ; genScheme = AST.ForGn n_id range
866 -- Create the content of the generate statement: Applying the mapped_f to
867 -- each of the elements in arg, storing to each element in res
868 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
869 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
870 ; resname = vecSlice fromRange toRange
871 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
872 ; out_assign = mkUncondAssign (Right resname) argexpr
874 -- Return the generate statement
875 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
878 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
879 (AST.ToRange init last))
881 genIteraten :: BuiltinBuilder
882 genIteraten dst f args = genIterate dst f (tail args)
884 genIterate :: BuiltinBuilder
885 genIterate = genIterateOrGenerate True
887 genGeneraten :: BuiltinBuilder
888 genGeneraten dst f args = genGenerate dst f (tail args)
890 genGenerate :: BuiltinBuilder
891 genGenerate = genIterateOrGenerate False
893 genIterateOrGenerate :: Bool -> BuiltinBuilder
894 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
896 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
897 genIterateOrGenerate' iter (Left res) f args = do
898 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
899 genIterateOrGenerate'' len iter (Left res) f args
901 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
902 -- Special case for an empty input vector, just assign start to res
903 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
905 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
907 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
908 -- An expression for len-1
909 let len_min_expr = (AST.PrimLit $ show (len-1))
910 -- -- evec is (TFVec n), so it still needs an element type
911 -- let (nvec, _) = splitAppTy (Var.varType vec)
912 -- -- Put the type of the start value in nvec, this will be the type of our
913 -- -- temporary vector
914 let tmp_ty = Var.varType res
915 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
916 -- TODO: Handle Nothing
917 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
918 -- Setup the generate scheme
919 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
920 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
921 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
922 let gen_scheme = AST.ForGn n_id gen_range
923 -- Make the intermediate vector
924 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
925 -- Create the generate statement
926 cells' <- sequence [genFirstCell, genOtherCell]
927 let (cells, useds) = unzip cells'
928 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
929 -- Assign tmp[len-1] or tmp[0] to res
930 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
931 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
932 return ([AST.CSBSm block], concat useds)
934 -- An id for the counter
935 n_id = mkVHDLBasicId "n"
936 n_cur = idToVHDLExpr n_id
937 -- An expression for previous n
938 n_prev = n_cur AST.:-: (AST.PrimLit "1")
939 -- An id for the tmp result vector
940 tmp_id = mkVHDLBasicId "tmp"
941 tmp_name = AST.NSimple tmp_id
942 -- Generate parts of the fold
943 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
945 let cond_label = mkVHDLExtId "firstcell"
946 -- if n == 0 or n == len-1
947 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
948 -- Output to tmp[current n]
949 let resname = mkIndexedName tmp_name n_cur
951 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
952 let startassign = mkUncondAssign (Right resname) argexpr
953 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
954 -- Return the conditional generate part
955 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
963 let cond_label = mkVHDLExtId "othercell"
964 -- if n > 0 or n < len-1
965 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
966 -- Output to tmp[current n]
967 let resname = mkIndexedName tmp_name n_cur
968 -- Input from tmp[previous n]
969 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
970 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
971 -- Return the conditional generate part
972 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
974 genBlockRAM :: BuiltinBuilder
975 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
977 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
978 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
980 let (tup,data_out) = Type.splitAppTy (Var.varType res)
981 let (tup',ramvec) = Type.splitAppTy tup
982 let Just realram = Type.coreView ramvec
983 let Just (tycon, types) = Type.splitTyConApp_maybe realram
984 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
985 -- Make the intermediate vector
986 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
987 -- Get the data_out name
988 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
989 let resname = varToVHDLName res
990 -- let resname = mkSelectedName resname' (reslabels!!0)
991 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
992 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
993 let assign = mkUncondAssign (Right resname) argexpr
994 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
995 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
996 return [AST.CSBSm block]
998 ram_id = mkVHDLBasicId "ram"
999 mkUpdateProcSm :: AST.ConcSm
1000 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
1002 proclabel = mkVHDLBasicId "updateRAM"
1003 rising_edge = mkVHDLBasicId "rising_edge"
1004 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
1005 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
1006 wform = AST.Wform [AST.WformElem data_in Nothing]
1007 ramassign = AST.SigAssign ramloc wform
1008 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
1009 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
1011 genSplit :: BuiltinBuilder
1012 genSplit = genNoInsts $ genVarArgs genSplit'
1014 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
1015 genSplit' (Left res) f args@[vecIn] = do {
1016 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
1017 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
1018 ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
1019 ; halflen = round ((fromIntegral len) / 2)
1020 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
1021 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
1022 ; resname = varToVHDLName res
1023 ; resnameL = mkSelectedName resname (labels!!0)
1024 ; resnameR = mkSelectedName resname (labels!!1)
1025 ; argexprL = vhdlNameToVHDLExpr rangeL
1026 ; argexprR = vhdlNameToVHDLExpr rangeR
1027 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1028 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1029 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1031 ; return [AST.CSBSm block]
1034 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1035 (AST.ToRange init last))
1036 -----------------------------------------------------------------------------
1037 -- Function to generate VHDL for applications
1038 -----------------------------------------------------------------------------
1040 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
1041 -> CoreSyn.CoreBndr -- ^ The function to apply
1042 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
1043 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1044 -- ^ The corresponding VHDL concurrent statements and entities
1046 genApplication dst f args = do
1047 nonemptydst <- case dst of
1048 Left bndr -> hasNonEmptyType bndr
1049 Right _ -> return True
1052 if Var.isGlobalId f then
1053 case Var.idDetails f of
1054 IdInfo.DataConWorkId dc -> case dst of
1055 -- It's a datacon. Create a record from its arguments.
1057 -- We have the bndr, so we can get at the type
1058 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1059 let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
1062 [arg'] <- argsToVHDLExprs [arg]
1063 return ([mkUncondAssign dst arg'], [])
1066 Right (AggrType _ _) -> do
1067 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
1068 args' <- argsToVHDLExprs argsNostate
1069 return (zipWith mkassign labels args', [])
1071 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1072 mkassign label arg =
1073 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1074 mkUncondAssign (Right sel_name) arg
1075 _ -> do -- error $ "DIE!"
1076 args' <- argsToVHDLExprs argsNostate
1077 return ([mkUncondAssign dst (head args')], [])
1078 Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1079 IdInfo.DataConWrapId dc -> case dst of
1080 -- It's a datacon. Create a record from its arguments.
1082 case (Map.lookup (varToString f) globalNameTable) of
1083 Just (arg_count, builder) ->
1084 if length args == arg_count then
1087 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1088 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1089 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1091 -- It's a global value imported from elsewhere. These can be builtin
1092 -- functions. Look up the function name in the name table and execute
1093 -- the associated builder if there is any and the argument count matches
1094 -- (this should always be the case if it typechecks, but just to be
1096 case (Map.lookup (varToString f) globalNameTable) of
1097 Just (arg_count, builder) ->
1098 if length args == arg_count then
1101 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1103 top <- isTopLevelBinder f
1106 -- Local binder that references a top level binding. Generate a
1107 -- component instantiation.
1108 signature <- getEntity f
1109 args' <- argsToVHDLExprs args
1110 let entity_id = ent_id signature
1111 -- TODO: Using show here isn't really pretty, but we'll need some
1112 -- unique-ish value...
1113 let label = "comp_ins_" ++ (either show prettyShow) dst
1114 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1115 return ([mkComponentInst label entity_id portmaps], [f])
1117 -- Not a top level binder, so this must be a local variable reference.
1118 -- It should have a representable type (and thus, no arguments) and a
1119 -- signal should be generated for it. Just generate an unconditional
1121 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1122 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1123 -- return $ ([mkUncondAssign dst f'], [])
1124 do errtype <- case dst of
1126 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1128 Right vhd -> return $ show vhd
1129 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1130 IdInfo.ClassOpId cls ->
1131 -- FIXME: Not looking for what instance this class op is called for
1132 -- Is quite stupid of course.
1133 case (Map.lookup (varToString f) globalNameTable) of
1134 Just (arg_count, builder) ->
1135 if length args == arg_count then
1138 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1139 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1140 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1142 top <- isTopLevelBinder f
1145 -- Local binder that references a top level binding. Generate a
1146 -- component instantiation.
1147 signature <- getEntity f
1148 args' <- argsToVHDLExprs args
1149 let entity_id = ent_id signature
1150 -- TODO: Using show here isn't really pretty, but we'll need some
1151 -- unique-ish value...
1152 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1153 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1154 return ([mkComponentInst label entity_id portmaps], [f])
1156 -- Not a top level binder, so this must be a local variable reference.
1157 -- It should have a representable type (and thus, no arguments) and a
1158 -- signal should be generated for it. Just generate an unconditional
1160 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1161 return ([mkUncondAssign dst f'], [])
1162 else -- Destination has empty type, don't generate anything
1164 -----------------------------------------------------------------------------
1165 -- Functions to generate functions dealing with vectors.
1166 -----------------------------------------------------------------------------
1168 -- Returns the VHDLId of the vector function with the given name for the given
1169 -- element type. Generates -- this function if needed.
1170 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1171 vectorFunId el_ty fname = do
1172 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1173 -- TODO: Handle the Nothing case?
1174 elemTM_maybe <- vhdlTy error_msg el_ty
1175 let elemTM = Maybe.fromMaybe
1176 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1178 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1179 -- the VHDLState or something.
1180 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1181 typefuns <- MonadState.get tsTypeFuns
1182 el_htype <- mkHType error_msg el_ty
1183 case Map.lookup (UVecType el_htype, fname) typefuns of
1184 -- Function already generated, just return it
1185 Just (id, _) -> return id
1186 -- Function not generated yet, generate it
1188 let functions = genUnconsVectorFuns elemTM vectorTM
1189 case lookup fname functions of
1191 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1192 mapM_ (vectorFunId el_ty) (snd body)
1194 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1196 function_id = mkVHDLExtId fname
1198 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1199 -> AST.TypeMark -- ^ type of the vector
1200 -> [(String, (AST.SubProgBody, [String]))]
1201 genUnconsVectorFuns elemTM vectorTM =
1202 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1203 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1204 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1205 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1206 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1207 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1208 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1209 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1210 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1211 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1212 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1213 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1214 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1215 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1216 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1217 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1218 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1219 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1220 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1221 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1222 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1225 ixPar = AST.unsafeVHDLBasicId "ix"
1226 vecPar = AST.unsafeVHDLBasicId "vec"
1227 vec1Par = AST.unsafeVHDLBasicId "vec1"
1228 vec2Par = AST.unsafeVHDLBasicId "vec2"
1229 nPar = AST.unsafeVHDLBasicId "n"
1230 leftPar = AST.unsafeVHDLBasicId "nLeft"
1231 rightPar = AST.unsafeVHDLBasicId "nRight"
1232 iId = AST.unsafeVHDLBasicId "i"
1234 aPar = AST.unsafeVHDLBasicId "a"
1235 fPar = AST.unsafeVHDLBasicId "f"
1236 sPar = AST.unsafeVHDLBasicId "s"
1237 resId = AST.unsafeVHDLBasicId "res"
1238 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1239 AST.IfaceVarDec ixPar unsignedTM] elemTM
1240 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1241 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1242 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1243 , AST.IfaceVarDec iPar unsignedTM
1244 , AST.IfaceVarDec aPar elemTM
1246 -- variable res : fsvec_x (0 to vec'length-1);
1249 (AST.SubtypeIn vectorTM
1250 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1251 [AST.ToRange (AST.PrimLit "0")
1252 (AST.PrimName (AST.NAttribute $
1253 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1254 (AST.PrimLit "1")) ]))
1256 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1257 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1258 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1259 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1260 vecSlice init last = AST.PrimName (AST.NSlice
1262 (AST.NSimple vecPar)
1263 (AST.ToRange init last)))
1264 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1265 -- return vec(vec'length-1);
1266 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1267 (AST.NSimple vecPar)
1268 [AST.PrimName (AST.NAttribute $
1269 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1270 AST.:-: AST.PrimLit "1"])))
1271 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1272 -- variable res : fsvec_x (0 to vec'length-2);
1275 (AST.SubtypeIn vectorTM
1276 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1277 [AST.ToRange (AST.PrimLit "0")
1278 (AST.PrimName (AST.NAttribute $
1279 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1280 (AST.PrimLit "2")) ]))
1282 -- resAST.:= vec(0 to vec'length-2)
1283 initExpr = AST.NSimple resId AST.:= (vecSlice
1285 (AST.PrimName (AST.NAttribute $
1286 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1287 AST.:-: AST.PrimLit "2"))
1288 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1289 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1290 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1291 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1292 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1294 (Just $ AST.Else [minimumExprRet])
1295 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1296 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1297 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1298 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1299 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1300 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1301 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1302 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1305 (AST.SubtypeIn vectorTM
1306 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1307 [AST.ToRange (AST.PrimLit "0")
1309 (AST.PrimLit "1")) ]))
1311 -- res AST.:= vec(0 to n-1)
1312 takeExpr = AST.NSimple resId AST.:=
1313 (vecSlice (AST.PrimLit "0")
1314 (minLength AST.:-: AST.PrimLit "1"))
1315 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1316 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1317 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1318 -- variable res : fsvec_x (0 to vec'length-n-1);
1321 (AST.SubtypeIn vectorTM
1322 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1323 [AST.ToRange (AST.PrimLit "0")
1324 (AST.PrimName (AST.NAttribute $
1325 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1326 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1328 -- res AST.:= vec(n to vec'length-1)
1329 dropExpr = AST.NSimple resId AST.:= (vecSlice
1330 (AST.PrimName $ AST.NSimple nPar)
1331 (AST.PrimName (AST.NAttribute $
1332 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1333 AST.:-: AST.PrimLit "1"))
1334 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1335 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1336 AST.IfaceVarDec vecPar vectorTM] vectorTM
1337 -- variable res : fsvec_x (0 to vec'length);
1340 (AST.SubtypeIn vectorTM
1341 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1342 [AST.ToRange (AST.PrimLit "0")
1343 (AST.PrimName (AST.NAttribute $
1344 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1346 plusgtExpr = AST.NSimple resId AST.:=
1347 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1348 (AST.PrimName $ AST.NSimple vecPar))
1349 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1350 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1353 (AST.SubtypeIn vectorTM
1354 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1355 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1357 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1358 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1360 -- variable res : fsvec_x (0 to 0) := (others => a);
1363 (AST.SubtypeIn vectorTM
1364 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1365 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1366 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1367 (AST.PrimName $ AST.NSimple aPar)])
1368 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1369 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1370 AST.IfaceVarDec aPar elemTM ] vectorTM
1371 -- variable res : fsvec_x (0 to n-1) := (others => a);
1374 (AST.SubtypeIn vectorTM
1375 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1376 [AST.ToRange (AST.PrimLit "0")
1377 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1378 (AST.PrimLit "1")) ]))
1379 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1380 (AST.PrimName $ AST.NSimple aPar)])
1382 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1383 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1384 AST.IfaceVarDec sPar naturalTM,
1385 AST.IfaceVarDec nPar naturalTM,
1386 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1387 -- variable res : fsvec_x (0 to n-1);
1390 (AST.SubtypeIn vectorTM
1391 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1392 [AST.ToRange (AST.PrimLit "0")
1393 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1394 (AST.PrimLit "1")) ])
1397 -- for i res'range loop
1398 -- res(i) := vec(f+i*s);
1400 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1401 -- res(i) := vec(f+i*s);
1402 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1403 (AST.PrimName (AST.NSimple iId) AST.:*:
1404 AST.PrimName (AST.NSimple sPar)) in
1405 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1406 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1408 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1409 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1410 AST.IfaceVarDec aPar elemTM] vectorTM
1411 -- variable res : fsvec_x (0 to vec'length);
1414 (AST.SubtypeIn vectorTM
1415 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1416 [AST.ToRange (AST.PrimLit "0")
1417 (AST.PrimName (AST.NAttribute $
1418 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1420 ltplusExpr = AST.NSimple resId AST.:=
1421 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1422 (AST.PrimName $ AST.NSimple aPar))
1423 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1424 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1425 AST.IfaceVarDec vec2Par vectorTM]
1427 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1430 (AST.SubtypeIn vectorTM
1431 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1432 [AST.ToRange (AST.PrimLit "0")
1433 (AST.PrimName (AST.NAttribute $
1434 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1435 AST.PrimName (AST.NAttribute $
1436 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1439 plusplusExpr = AST.NSimple resId AST.:=
1440 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1441 (AST.PrimName $ AST.NSimple vec2Par))
1442 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1443 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1444 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1445 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1446 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1447 AST.IfaceVarDec aPar elemTM ] vectorTM
1448 -- variable res : fsvec_x (0 to vec'length-1);
1451 (AST.SubtypeIn vectorTM
1452 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1453 [AST.ToRange (AST.PrimLit "0")
1454 (AST.PrimName (AST.NAttribute $
1455 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1456 (AST.PrimLit "1")) ]))
1458 -- res := a & init(vec)
1459 shiftlExpr = AST.NSimple resId AST.:=
1460 (AST.PrimName (AST.NSimple aPar) AST.:&:
1461 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1462 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1463 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1464 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1465 AST.IfaceVarDec aPar elemTM ] vectorTM
1466 -- variable res : fsvec_x (0 to vec'length-1);
1469 (AST.SubtypeIn vectorTM
1470 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1471 [AST.ToRange (AST.PrimLit "0")
1472 (AST.PrimName (AST.NAttribute $
1473 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1474 (AST.PrimLit "1")) ]))
1476 -- res := tail(vec) & a
1477 shiftrExpr = AST.NSimple resId AST.:=
1478 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1479 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1480 (AST.PrimName (AST.NSimple aPar)))
1482 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1483 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1484 -- return vec'length = 0
1485 nullExpr = AST.ReturnSm (Just $
1486 AST.PrimName (AST.NAttribute $
1487 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1489 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1490 -- variable res : fsvec_x (0 to vec'length-1);
1493 (AST.SubtypeIn vectorTM
1494 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1495 [AST.ToRange (AST.PrimLit "0")
1496 (AST.PrimName (AST.NAttribute $
1497 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1498 (AST.PrimLit "1")) ]))
1500 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1501 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1502 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1503 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1505 (Just $ AST.Else [rotlExprRet])
1507 AST.NSimple resId AST.:=
1508 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1509 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1510 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1511 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1512 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1513 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1514 -- variable res : fsvec_x (0 to vec'length-1);
1517 (AST.SubtypeIn vectorTM
1518 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1519 [AST.ToRange (AST.PrimLit "0")
1520 (AST.PrimName (AST.NAttribute $
1521 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1522 (AST.PrimLit "1")) ]))
1524 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1525 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1526 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1527 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1529 (Just $ AST.Else [rotrExprRet])
1531 AST.NSimple resId AST.:=
1532 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1533 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1534 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1535 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1536 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1537 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1540 (AST.SubtypeIn vectorTM
1541 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1542 [AST.ToRange (AST.PrimLit "0")
1543 (AST.PrimName (AST.NAttribute $
1544 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1545 (AST.PrimLit "1")) ]))
1547 -- for i in 0 to res'range loop
1548 -- res(vec'length-i-1) := vec(i);
1551 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1552 -- res(vec'length-i-1) := vec(i);
1553 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1554 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1555 [AST.PrimName $ AST.NSimple iId]))
1556 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1557 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1558 AST.PrimName (AST.NSimple iId) AST.:-:
1561 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1564 -----------------------------------------------------------------------------
1565 -- A table of builtin functions
1566 -----------------------------------------------------------------------------
1568 -- A function that generates VHDL for a builtin function
1569 type BuiltinBuilder =
1570 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1571 -> CoreSyn.CoreBndr -- ^ The function called
1572 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1573 -- dictionary arguments).
1574 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1575 -- ^ The corresponding VHDL concurrent statements and entities
1578 -- A map of a builtin function to VHDL function builder
1579 type NameTable = Map.Map String (Int, BuiltinBuilder )
1581 -- | The builtin functions we support. Maps a name to an argument count and a
1582 -- builder function. If you add a name to this map, don't forget to add
1583 -- it to VHDL.Constants/builtinIds as well.
1584 globalNameTable :: NameTable
1585 globalNameTable = Map.fromList
1586 [ (exId , (2, genFCall True ) )
1587 , (replaceId , (3, genFCall False ) )
1588 , (headId , (1, genFCall True ) )
1589 , (lastId , (1, genFCall True ) )
1590 , (tailId , (1, genFCall False ) )
1591 , (initId , (1, genFCall False ) )
1592 , (takeId , (2, genFCall False ) )
1593 , (dropId , (2, genFCall False ) )
1594 , (selId , (4, genFCall False ) )
1595 , (plusgtId , (2, genFCall False ) )
1596 , (ltplusId , (2, genFCall False ) )
1597 , (plusplusId , (2, genFCall False ) )
1598 , (mapId , (2, genMap ) )
1599 , (zipWithId , (3, genZipWith ) )
1600 , (foldlId , (3, genFoldl ) )
1601 , (foldrId , (3, genFoldr ) )
1602 , (zipId , (2, genZip ) )
1603 , (unzipId , (1, genUnzip ) )
1604 , (shiftlId , (2, genFCall False ) )
1605 , (shiftrId , (2, genFCall False ) )
1606 , (rotlId , (1, genFCall False ) )
1607 , (rotrId , (1, genFCall False ) )
1608 , (concatId , (1, genConcat ) )
1609 , (reverseId , (1, genFCall False ) )
1610 , (iteratenId , (3, genIteraten ) )
1611 , (iterateId , (2, genIterate ) )
1612 , (generatenId , (3, genGeneraten ) )
1613 , (generateId , (2, genGenerate ) )
1614 , (emptyId , (0, genFCall False ) )
1615 , (singletonId , (1, genFCall False ) )
1616 , (copynId , (2, genFCall False ) )
1617 , (copyId , (1, genCopy ) )
1618 , (lengthTId , (1, genFCall False ) )
1619 , (nullId , (1, genFCall False ) )
1620 , (hwxorId , (2, genOperator2 AST.Xor ) )
1621 , (hwandId , (2, genOperator2 AST.And ) )
1622 , (hworId , (2, genOperator2 AST.Or ) )
1623 , (hwnotId , (1, genOperator1 AST.Not ) )
1624 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1625 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1626 , (ltId , (2, genOperator2 (AST.:<:) ) )
1627 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1628 , (gtId , (2, genOperator2 (AST.:>:) ) )
1629 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1630 , (boolOrId , (2, genOperator2 AST.Or ) )
1631 , (boolAndId , (2, genOperator2 AST.And ) )
1632 , (boolNot , (1, genOperator1 AST.Not ) )
1633 , (plusId , (2, genOperator2 (AST.:+:) ) )
1634 , (timesId , (2, genTimes ) )
1635 , (negateId , (1, genNegation ) )
1636 , (minusId , (2, genOperator2 (AST.:-:) ) )
1637 , (fromSizedWordId , (1, genFromSizedWord ) )
1638 , (fromRangedWordId , (1, genFromRangedWord ) )
1639 , (fromIntegerId , (1, genFromInteger ) )
1640 , (resizeWordId , (1, genResize ) )
1641 , (resizeIntId , (1, genResize ) )
1642 , (sizedIntId , (1, genSizedInt ) )
1643 , (smallIntegerId , (1, genFromInteger ) )
1644 , (fstId , (1, genFst ) )
1645 , (sndId , (1, genSnd ) )
1646 , (blockRAMId , (5, genBlockRAM ) )
1647 , (splitId , (1, genSplit ) )
1648 --, (tfvecId , (1, genTFVec ) )
1649 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))