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.fromJust type_mark_old_maybe
176 type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
177 let type_mark_res' = Maybe.fromJust type_mark_res_maybe
178 let type_mark_res = if type_mark_old == type_mark_res' then
181 error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: " ++ show type_mark_res'
182 let resvalid = mkVHDLExtId $ varToString res ++ "val"
183 let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
184 let reswform = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
185 let res_assign = AST.SigAssign (varToVHDLName old) reswform
186 let blocklabel = mkVHDLBasicId "state"
187 let statelabel = mkVHDLBasicId "stateupdate"
188 let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
189 let wform = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
190 let clk_assign = AST.SigAssign (varToVHDLName old) wform
191 let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
192 let resetn_is_low = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
193 signature <- getEntity res
194 let entity_id = ent_id signature
195 let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
196 let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
197 let reset_statement = mkComponentInst reslabel entity_id portmaps
198 let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
199 let statement = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
200 let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
201 let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
202 return ([block],[res])
204 -- | Transforms a core binding into a VHDL concurrent statement
206 (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
207 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
208 -- ^ The corresponding VHDL concurrent statements and entities
212 -- Ignore Cast expressions, they should not longer have any meaning as long as
213 -- the type works out. Throw away state repacking
214 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
215 | hasStateType to && hasStateType from
217 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
219 -- Simple a = b assignments are just like applications, but without arguments.
220 -- We can't just generate an unconditional assignment here, since b might be a
221 -- top level binding (e.g., a function with no arguments).
222 mkConcSm (bndr, CoreSyn.Var v) =
223 genApplication (Left bndr) v []
225 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
226 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
227 let valargs = get_val_args (Var.varType f) args
228 genApplication (Left bndr) f (map Left valargs)
230 -- A single alt case must be a selector. This means the scrutinee is a simple
231 -- variable, the alternative is a dataalt with a single non-wild binder that
233 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
234 -- Don't generate VHDL for substate extraction
235 | hasStateType bndr = return ([], [])
238 (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
239 nonemptysel <- hasNonEmptyType sel_bndr
242 bndrs' <- Monad.filterM hasNonEmptyType bndrs
243 case List.elemIndex sel_bndr bndrs' of
245 htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
246 htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
247 case htypeScrt == htypeBndr of
249 let sel_name = varToVHDLName scrut
250 let sel_expr = AST.PrimName sel_name
251 return ([mkUncondAssign (Left bndr) sel_expr], [])
254 Right (AggrType _ _) -> do
255 labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
256 let label = labels!!i
257 let sel_name = mkSelectedName (varToVHDLName scrut) label
258 let sel_expr = AST.PrimName sel_name
259 return ([mkUncondAssign (Left bndr) sel_expr], [])
260 _ -> do -- error $ "DIE!"
261 let sel_name = varToVHDLName scrut
262 let sel_expr = AST.PrimName sel_name
263 return ([mkUncondAssign (Left bndr) sel_expr], [])
264 Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
266 -- A selector case that selects a state value, ignore it.
269 _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
271 -- Multiple case alt are be conditional assignments and have only wild
272 -- binders in the alts and only variables in the case values and a variable
273 -- for a scrutinee. We check the constructor of the second alt, since the
274 -- first is the default case, if there is any.
276 -- mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
277 -- scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
278 -- altcon <- MonadState.lift tsType $ altconToVHDLExpr con
279 -- let cond_expr = scrut' AST.:=: altcon
280 -- true_expr <- MonadState.lift tsType $ varToVHDLExpr true
281 -- false_expr <- MonadState.lift tsType $ varToVHDLExpr false
282 -- return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
283 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) _ _ (alt:alts))) = do --error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
284 scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
285 -- Omit first condition, which is the default
286 altcons <- MonadState.lift tsType $ mapM (altconToVHDLExpr . (\(con,_,_) -> con)) alts
287 let cond_exprs = map (\x -> scrut' AST.:=: x) altcons
288 -- Rotate expressions to the left, so that the expression related to the default case is the last
289 exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) (alts ++ [alt])
290 return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
292 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
293 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
295 -----------------------------------------------------------------------------
296 -- Functions to generate VHDL for builtin functions
297 -----------------------------------------------------------------------------
299 -- | A function to wrap a builder-like function that expects its arguments to
301 genExprArgs wrap dst func args = do
302 args' <- argsToVHDLExprs args
305 -- | Turn the all lefts into VHDL Expressions.
306 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
307 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
309 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
310 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
311 let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
312 ty_maybe <- vhdlTy errmsg expr
315 vhdl_expr <- varToVHDLExpr $ exprToVar expr
316 return $ Just vhdl_expr
317 Nothing -> return Nothing
319 argToVHDLExpr (Right expr) = return $ Just expr
321 -- A function to wrap a builder-like function that generates no component
324 (dst -> func -> args -> TranslatorSession [AST.ConcSm])
325 -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
326 genNoInsts wrap dst func args = do
327 concsms <- wrap dst func args
330 -- | A function to wrap a builder-like function that expects its arguments to
333 (dst -> func -> [Var.Var] -> res)
334 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
335 genVarArgs wrap dst func args = wrap dst func args'
337 args' = map exprToVar exprargs
338 -- Check (rather crudely) that all arguments are CoreExprs
339 (exprargs, []) = Either.partitionEithers args
341 -- | A function to wrap a builder-like function that expects its arguments to
344 (dst -> func -> [Literal.Literal] -> TranslatorSession [AST.ConcSm])
345 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.ConcSm])
346 genLitArgs wrap dst func args = do
347 hscenv <- MonadState.lift tsType $ MonadState.get tsHscEnv
348 let (exprargs, []) = Either.partitionEithers args
349 -- FIXME: Check if we were passed an CoreSyn.App
350 let litargs = concatMap (getLiterals hscenv) exprargs
351 let args' = map exprToLit litargs
354 -- | A function to wrap a builder-like function that produces an expression
355 -- and expects it to be assigned to the destination.
357 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
358 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
359 genExprRes wrap dst func args = do
360 expr <- wrap dst func args
361 return [mkUncondAssign dst expr]
363 -- | Generate a binary operator application. The first argument should be a
364 -- constructor from the AST.Expr type, e.g. AST.And.
365 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
366 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
367 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
368 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
370 -- | Generate a unary operator application
371 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
372 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
373 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
374 genOperator1' op _ f [arg] = return $ op arg
376 -- | Generate a unary operator application
377 genNegation :: BuiltinBuilder
378 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
379 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
380 genNegation' _ f [arg] = do
381 arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
382 let ty = Var.varType arg
383 let (tycon, args) = Type.splitTyConApp ty
384 let name = Name.getOccString (TyCon.tyConName tycon)
386 "SizedInt" -> return $ AST.Neg arg1
387 otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name
389 -- | Generate a function call from the destination binder, function name and a
390 -- list of expressions (its arguments)
391 genFCall :: Bool -> BuiltinBuilder
392 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
393 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
394 genFCall' switch (Left res) f args = do
395 let fname = varToString f
396 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
397 id <- MonadState.lift tsType $ vectorFunId el_ty fname
398 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
399 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
400 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
402 genFromSizedWord :: BuiltinBuilder
403 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
404 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
405 genFromSizedWord' (Left res) f args@[arg] =
406 return [mkUncondAssign (Left res) arg]
407 -- let fname = varToString f
408 -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
409 -- map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
410 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
412 genResize :: BuiltinBuilder
413 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
414 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
415 genResize' (Left res) f [arg] = do {
416 ; let { ty = Var.varType res
417 ; (tycon, args) = Type.splitTyConApp ty
418 ; name = Name.getOccString (TyCon.tyConName tycon)
420 ; len <- case name of
421 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
422 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
423 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
424 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
426 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
428 genTimes :: BuiltinBuilder
429 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
430 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
431 genTimes' (Left res) f [arg1,arg2] = do {
432 ; let { ty = Var.varType res
433 ; (tycon, args) = Type.splitTyConApp ty
434 ; name = Name.getOccString (TyCon.tyConName tycon)
436 ; len <- case name of
437 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
438 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
439 "RangedWord" -> do { ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
440 ; let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
443 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
444 [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
446 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
448 -- FIXME: I'm calling genLitArgs which is very specific function,
449 -- which needs to be fixed as well
450 genFromInteger :: BuiltinBuilder
451 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
452 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
453 genFromInteger' (Left res) f lits = do {
454 ; let { ty = Var.varType res
455 ; (tycon, args) = Type.splitTyConApp ty
456 ; name = Name.getOccString (TyCon.tyConName tycon)
458 ; len <- case name of
459 "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
460 "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
462 ; bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
463 ; return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
465 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId ; "RangedWord" -> toUnsignedId
466 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
467 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
471 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
473 genSizedInt :: BuiltinBuilder
474 genSizedInt = genFromInteger
477 -- | Generate a Builder for the builtin datacon TFVec
478 genTFVec :: BuiltinBuilder
479 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
480 -- Generate Assignments for all the binders
481 ; letAssigns <- mapM genBinderAssign letBinders
482 -- Generate assignments for the result (which might be another let binding)
483 ; (resBinders,resAssignments) <- genResAssign letRes
484 -- Get all the Assigned binders
485 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
486 -- Make signal names for all the assigned binders
487 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
488 -- Assign all the signals to the resulting vector
489 ; let { vecsigns = mkAggregateSignal sigs
490 ; vecassign = mkUncondAssign (Left res) vecsigns
492 -- Generate all the signal declaration for the assigned binders
493 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
494 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
495 -- Setup the VHDL Block
496 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
497 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
499 -- Return the block statement coressponding to the TFVec literal
500 ; return $ [AST.CSBSm block]
503 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
504 -- For now we only translate applications
505 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
506 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
507 let valargs = get_val_args (Var.varType f) args
508 apps <- genApplication (Left bndr) f (map Left valargs)
509 return (Just bndr, apps)
510 genBinderAssign _ = return (Nothing,[])
511 genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
512 genResAssign app@(CoreSyn.App _ letexpr) = do
514 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
515 letapps <- mapM genBinderAssign letbndrs
516 let bndrs = Maybe.catMaybes (map fst letapps)
517 let app = (map snd letapps)
518 (vars, apps) <- genResAssign letres
519 return ((bndrs ++ vars),((concat app) ++ apps))
520 otherwise -> return ([],[])
521 genResAssign _ = return ([],[])
523 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
524 ; let { elems = reduceCoreListToHsList app
525 -- Make signal names for all the binders
526 ; binders = map (\expr -> case expr of
528 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
529 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
531 ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
532 -- Assign all the signals to the resulting vector
533 ; let { vecsigns = mkAggregateSignal sigs
534 ; vecassign = mkUncondAssign (Left res) vecsigns
535 -- Setup the VHDL Block
536 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
537 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
539 -- Return the block statement coressponding to the TFVec literal
540 ; return $ [AST.CSBSm block]
543 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
545 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
547 -- | Generate a generate statement for the builtin function "map"
548 genMap :: BuiltinBuilder
549 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
550 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
551 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
552 -- we must index it (which we couldn't if it was a VHDL Expr, since only
553 -- VHDLNames can be indexed).
554 -- Setup the generate scheme
555 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
556 -- TODO: Use something better than varToString
557 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
558 ; n_id = mkVHDLBasicId "n"
559 ; n_expr = idToVHDLExpr n_id
560 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
561 ; genScheme = AST.ForGn n_id range
562 -- Create the content of the generate statement: Applying the mapped_f to
563 -- each of the elements in arg, storing to each element in res
564 ; resname = mkIndexedName (varToVHDLName res) n_expr
565 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
566 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
567 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
569 ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
570 -- Return the generate statement
571 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
574 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
576 genZipWith :: BuiltinBuilder
577 genZipWith = genVarArgs genZipWith'
578 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
579 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
580 -- Setup the generate scheme
581 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
582 -- TODO: Use something better than varToString
583 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
584 ; n_id = mkVHDLBasicId "n"
585 ; n_expr = idToVHDLExpr n_id
586 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
587 ; genScheme = AST.ForGn n_id range
588 -- Create the content of the generate statement: Applying the zipped_f to
589 -- each of the elements in arg1 and arg2, storing to each element in res
590 ; resname = mkIndexedName (varToVHDLName res) n_expr
591 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
592 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
594 ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
595 -- Return the generate functions
596 ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
599 genFoldl :: BuiltinBuilder
600 genFoldl = genFold True
602 genFoldr :: BuiltinBuilder
603 genFoldr = genFold False
605 genFold :: Bool -> BuiltinBuilder
606 genFold left = genVarArgs (genFold' left)
608 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
609 genFold' left res f args@[folded_f , start ,vec]= do
610 len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty (Var.varType vec))
611 genFold'' len left res f args
613 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
614 -- Special case for an empty input vector, just assign start to res
615 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
616 arg <- MonadState.lift tsType $ varToVHDLExpr start
617 return ([mkUncondAssign (Left res) arg], [])
619 genFold'' len left (Left res) f [folded_f, start, vec] = do
621 --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
622 -- An expression for len-1
623 let len_min_expr = (AST.PrimLit $ show (len-1))
624 -- evec is (TFVec n), so it still needs an element type
625 let (nvec, _) = Type.splitAppTy (Var.varType vec)
626 -- Put the type of the start value in nvec, this will be the type of our
628 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
629 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
630 -- TODO: Handle Nothing
631 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
632 -- Setup the generate scheme
633 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
634 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
635 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
636 else AST.DownRange len_min_expr (AST.PrimLit "0")
637 let gen_scheme = AST.ForGn n_id gen_range
638 -- Make the intermediate vector
639 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
640 -- Create the generate statement
641 cells' <- sequence [genFirstCell, genOtherCell]
642 let (cells, useds) = unzip cells'
643 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
644 -- Assign tmp[len-1] or tmp[0] to res
645 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
646 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
647 (mkIndexedName tmp_name (AST.PrimLit "0")))
648 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
649 return ([AST.CSBSm block], concat useds)
651 -- An id for the counter
652 n_id = mkVHDLBasicId "n"
653 n_cur = idToVHDLExpr n_id
654 -- An expression for previous n
655 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
656 else (n_cur AST.:+: (AST.PrimLit "1"))
657 -- An id for the tmp result vector
658 tmp_id = mkVHDLBasicId "tmp"
659 tmp_name = AST.NSimple tmp_id
660 -- Generate parts of the fold
661 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
663 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
664 let cond_label = mkVHDLExtId "firstcell"
665 -- if n == 0 or n == len-1
666 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
667 else (AST.PrimLit $ show (len-1)))
668 -- Output to tmp[current n]
669 let resname = mkIndexedName tmp_name n_cur
671 argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
672 -- Input from vec[current n]
673 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
674 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
675 [Right argexpr1, Right argexpr2]
677 [Right argexpr2, Right argexpr1]
679 -- Return the conditional generate part
680 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
683 len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
684 let cond_label = mkVHDLExtId "othercell"
685 -- if n > 0 or n < len-1
686 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
687 else (AST.PrimLit $ show (len-1)))
688 -- Output to tmp[current n]
689 let resname = mkIndexedName tmp_name n_cur
690 -- Input from tmp[previous n]
691 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
692 -- Input from vec[current n]
693 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
694 (app_concsms, used) <- genApplication (Right resname) folded_f ( if left then
695 [Right argexpr1, Right argexpr2]
697 [Right argexpr2, Right argexpr1]
699 -- Return the conditional generate part
700 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
702 -- | Generate a generate statement for the builtin function "zip"
703 genZip :: BuiltinBuilder
704 genZip = genNoInsts $ genVarArgs genZip'
705 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
706 genZip' (Left res) f args@[arg1, arg2] = do {
707 -- Setup the generate scheme
708 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
709 -- TODO: Use something better than varToString
710 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
711 ; n_id = mkVHDLBasicId "n"
712 ; n_expr = idToVHDLExpr n_id
713 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
714 ; genScheme = AST.ForGn n_id range
715 ; resname' = mkIndexedName (varToVHDLName res) n_expr
716 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
717 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
719 ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
720 ; let { resnameA = mkSelectedName resname' (labels!!0)
721 ; resnameB = mkSelectedName resname' (labels!!1)
722 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
723 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
725 -- Return the generate functions
726 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
729 -- | Generate a generate statement for the builtin function "fst"
730 genFst :: BuiltinBuilder
731 genFst = genNoInsts $ genVarArgs genFst'
732 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
733 genFst' (Left res) f args@[arg] = do {
734 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
735 ; let { argexpr' = varToVHDLName arg
736 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!0)
737 ; assign = mkUncondAssign (Left res) argexprA
739 -- Return the generate functions
743 -- | Generate a generate statement for the builtin function "snd"
744 genSnd :: BuiltinBuilder
745 genSnd = genNoInsts $ genVarArgs genSnd'
746 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
747 genSnd' (Left res) f args@[arg] = do {
748 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType arg)
749 ; let { argexpr' = varToVHDLName arg
750 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (labels!!1)
751 ; assign = mkUncondAssign (Left res) argexprB
753 -- Return the generate functions
757 -- | Generate a generate statement for the builtin function "unzip"
758 genUnzip :: BuiltinBuilder
759 genUnzip = genNoInsts $ genVarArgs genUnzip'
760 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
761 genUnzip' (Left res) f args@[arg] = do
762 let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ pprString arg
763 htype <- MonadState.lift tsType $ mkHType error_msg (Var.varType arg)
764 -- Prepare a unconditional assignment, for the case when either part
765 -- of the unzip is a state variable, which will disappear in the
766 -- resulting VHDL, making the the unzip no longer required.
768 -- A normal vector containing two-tuples
769 VecType _ (AggrType _ [_, _]) -> do {
770 -- Setup the generate scheme
771 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
772 -- TODO: Use something better than varToString
773 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
774 ; n_id = mkVHDLBasicId "n"
775 ; n_expr = idToVHDLExpr n_id
776 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
777 ; genScheme = AST.ForGn n_id range
778 ; resname' = varToVHDLName res
779 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
781 ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
782 ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
783 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
784 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
785 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
786 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
787 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
788 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
790 -- Return the generate functions
791 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
793 -- Both elements of the tuple were state, so they've disappeared. No
794 -- need to do anything
795 VecType _ (AggrType _ []) -> return []
796 -- A vector containing aggregates with more than two elements?
797 VecType _ (AggrType _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg)
798 -- One of the elements of the tuple was state, so there won't be a
799 -- tuple (record) in the VHDL output. We can just do a plain
802 argexpr <- MonadState.lift tsType $ varToVHDLExpr arg
803 return [mkUncondAssign (Left res) argexpr]
804 _ -> error $ "Unzipping a value that is not a vector? Value: " ++ pprString arg ++ "\nType: " ++ pprString (Var.varType arg) ++ "\nhtype: " ++ show htype
806 genCopy :: BuiltinBuilder
807 genCopy = genNoInsts $ genVarArgs genCopy'
808 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
809 genCopy' (Left res) f args@[arg] =
811 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
812 (AST.PrimName (varToVHDLName arg))]
813 out_assign = mkUncondAssign (Left res) resExpr
817 genConcat :: BuiltinBuilder
818 genConcat = genNoInsts $ genVarArgs genConcat'
819 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
820 genConcat' (Left res) f args@[arg] = do {
821 -- Setup the generate scheme
822 ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
823 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
824 ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
825 -- TODO: Use something better than varToString
826 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
827 ; n_id = mkVHDLBasicId "n"
828 ; n_expr = idToVHDLExpr n_id
829 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
830 ; genScheme = AST.ForGn n_id range
831 -- Create the content of the generate statement: Applying the mapped_f to
832 -- each of the elements in arg, storing to each element in res
833 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
834 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
835 ; resname = vecSlice fromRange toRange
836 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
837 ; out_assign = mkUncondAssign (Right resname) argexpr
839 -- Return the generate statement
840 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
843 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
844 (AST.ToRange init last))
846 genIteraten :: BuiltinBuilder
847 genIteraten dst f args = genIterate dst f (tail args)
849 genIterate :: BuiltinBuilder
850 genIterate = genIterateOrGenerate True
852 genGeneraten :: BuiltinBuilder
853 genGeneraten dst f args = genGenerate dst f (tail args)
855 genGenerate :: BuiltinBuilder
856 genGenerate = genIterateOrGenerate False
858 genIterateOrGenerate :: Bool -> BuiltinBuilder
859 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
861 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
862 genIterateOrGenerate' iter (Left res) f args = do
863 len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
864 genIterateOrGenerate'' len iter (Left res) f args
866 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
867 -- Special case for an empty input vector, just assign start to res
868 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
870 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
872 -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
873 -- An expression for len-1
874 let len_min_expr = (AST.PrimLit $ show (len-1))
875 -- -- evec is (TFVec n), so it still needs an element type
876 -- let (nvec, _) = splitAppTy (Var.varType vec)
877 -- -- Put the type of the start value in nvec, this will be the type of our
878 -- -- temporary vector
879 let tmp_ty = Var.varType res
880 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
881 -- TODO: Handle Nothing
882 Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
883 -- Setup the generate scheme
884 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
885 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
886 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
887 let gen_scheme = AST.ForGn n_id gen_range
888 -- Make the intermediate vector
889 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
890 -- Create the generate statement
891 cells' <- sequence [genFirstCell, genOtherCell]
892 let (cells, useds) = unzip cells'
893 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
894 -- Assign tmp[len-1] or tmp[0] to res
895 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
896 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
897 return ([AST.CSBSm block], concat useds)
899 -- An id for the counter
900 n_id = mkVHDLBasicId "n"
901 n_cur = idToVHDLExpr n_id
902 -- An expression for previous n
903 n_prev = n_cur AST.:-: (AST.PrimLit "1")
904 -- An id for the tmp result vector
905 tmp_id = mkVHDLBasicId "tmp"
906 tmp_name = AST.NSimple tmp_id
907 -- Generate parts of the fold
908 genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
910 let cond_label = mkVHDLExtId "firstcell"
911 -- if n == 0 or n == len-1
912 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
913 -- Output to tmp[current n]
914 let resname = mkIndexedName tmp_name n_cur
916 argexpr <- MonadState.lift tsType $ varToVHDLExpr start
917 let startassign = mkUncondAssign (Right resname) argexpr
918 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
919 -- Return the conditional generate part
920 let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
928 let cond_label = mkVHDLExtId "othercell"
929 -- if n > 0 or n < len-1
930 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
931 -- Output to tmp[current n]
932 let resname = mkIndexedName tmp_name n_cur
933 -- Input from tmp[previous n]
934 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
935 (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
936 -- Return the conditional generate part
937 return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
939 genBlockRAM :: BuiltinBuilder
940 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
942 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession [AST.ConcSm]
943 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
945 let (tup,data_out) = Type.splitAppTy (Var.varType res)
946 let (tup',ramvec) = Type.splitAppTy tup
947 let Just realram = Type.coreView ramvec
948 let Just (tycon, types) = Type.splitTyConApp_maybe realram
949 Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
950 -- Make the intermediate vector
951 let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
952 -- Get the data_out name
953 -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
954 let resname = varToVHDLName res
955 -- let resname = mkSelectedName resname' (reslabels!!0)
956 let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) rdaddr
957 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
958 let assign = mkUncondAssign (Right resname) argexpr
959 let block_label = mkVHDLExtId ("blockRAM" ++ (varToString res))
960 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
961 return [AST.CSBSm block]
963 ram_id = mkVHDLBasicId "ram"
964 mkUpdateProcSm :: AST.ConcSm
965 mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
967 proclabel = mkVHDLBasicId "updateRAM"
968 rising_edge = mkVHDLBasicId "rising_edge"
969 wraddr_int = genExprFCall (mkVHDLBasicId toIntegerId) wraddr
970 ramloc = mkIndexedName (AST.NSimple ram_id) wraddr_int
971 wform = AST.Wform [AST.WformElem data_in Nothing]
972 ramassign = AST.SigAssign ramloc wform
973 rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
974 statement = AST.IfSm (AST.And rising_edge_clk wrenable) [ramassign] [] Nothing
976 genSplit :: BuiltinBuilder
977 genSplit = genNoInsts $ genVarArgs genSplit'
979 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
980 genSplit' (Left res) f args@[vecIn] = do {
981 ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
982 ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
983 ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
984 ; halflen = round ((fromIntegral len) / 2)
985 ; rangeL = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
986 ; rangeR = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
987 ; resname = varToVHDLName res
988 ; resnameL = mkSelectedName resname (labels!!0)
989 ; resnameR = mkSelectedName resname (labels!!1)
990 ; argexprL = vhdlNameToVHDLExpr rangeL
991 ; argexprR = vhdlNameToVHDLExpr rangeR
992 ; out_assignL = mkUncondAssign (Right resnameL) argexprL
993 ; out_assignR = mkUncondAssign (Right resnameR) argexprR
994 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
996 ; return [AST.CSBSm block]
999 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
1000 (AST.ToRange init last))
1001 -----------------------------------------------------------------------------
1002 -- Function to generate VHDL for applications
1003 -----------------------------------------------------------------------------
1005 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
1006 -> CoreSyn.CoreBndr -- ^ The function to apply
1007 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
1008 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1009 -- ^ The corresponding VHDL concurrent statements and entities
1011 genApplication dst f args =
1012 if Var.isGlobalId f then
1013 case Var.idDetails f of
1014 IdInfo.DataConWorkId dc -> case dst of
1015 -- It's a datacon. Create a record from its arguments.
1017 -- We have the bndr, so we can get at the type
1018 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1019 let argsNostate = filter (\x -> not (either hasStateType (\x -> False) x)) args
1022 [arg'] <- argsToVHDLExprs [arg]
1023 return ([mkUncondAssign dst arg'], [])
1026 Right (AggrType _ _) -> do
1027 labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
1028 args' <- argsToVHDLExprs argsNostate
1029 return (zipWith mkassign labels args', [])
1031 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1032 mkassign label arg =
1033 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1034 mkUncondAssign (Right sel_name) arg
1035 _ -> do -- error $ "DIE!"
1036 args' <- argsToVHDLExprs argsNostate
1037 return ([mkUncondAssign dst (head args')], [])
1038 Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1039 IdInfo.DataConWrapId dc -> case dst of
1040 -- It's a datacon. Create a record from its arguments.
1042 case (Map.lookup (varToString f) globalNameTable) of
1043 Just (arg_count, builder) ->
1044 if length args == arg_count then
1047 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1048 Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1049 Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1051 -- It's a global value imported from elsewhere. These can be builtin
1052 -- functions. Look up the function name in the name table and execute
1053 -- the associated builder if there is any and the argument count matches
1054 -- (this should always be the case if it typechecks, but just to be
1056 case (Map.lookup (varToString f) globalNameTable) of
1057 Just (arg_count, builder) ->
1058 if length args == arg_count then
1061 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1063 top <- isTopLevelBinder f
1066 -- Local binder that references a top level binding. Generate a
1067 -- component instantiation.
1068 signature <- getEntity f
1069 args' <- argsToVHDLExprs args
1070 let entity_id = ent_id signature
1071 -- TODO: Using show here isn't really pretty, but we'll need some
1072 -- unique-ish value...
1073 let label = "comp_ins_" ++ (either show prettyShow) dst
1074 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1075 return ([mkComponentInst label entity_id portmaps], [f])
1077 -- Not a top level binder, so this must be a local variable reference.
1078 -- It should have a representable type (and thus, no arguments) and a
1079 -- signal should be generated for it. Just generate an unconditional
1081 -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1082 -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1083 -- return $ ([mkUncondAssign dst f'], [])
1084 do errtype <- case dst of
1086 htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1088 Right vhd -> return $ show vhd
1089 error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1090 IdInfo.ClassOpId cls ->
1091 -- FIXME: Not looking for what instance this class op is called for
1092 -- Is quite stupid of course.
1093 case (Map.lookup (varToString f) globalNameTable) of
1094 Just (arg_count, builder) ->
1095 if length args == arg_count then
1098 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1099 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1100 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1102 top <- isTopLevelBinder f
1105 -- Local binder that references a top level binding. Generate a
1106 -- component instantiation.
1107 signature <- getEntity f
1108 args' <- argsToVHDLExprs args
1109 let entity_id = ent_id signature
1110 -- TODO: Using show here isn't really pretty, but we'll need some
1111 -- unique-ish value...
1112 let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1113 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1114 return ([mkComponentInst label entity_id portmaps], [f])
1116 -- Not a top level binder, so this must be a local variable reference.
1117 -- It should have a representable type (and thus, no arguments) and a
1118 -- signal should be generated for it. Just generate an unconditional
1120 do f' <- MonadState.lift tsType $ varToVHDLExpr f
1121 return ([mkUncondAssign dst f'], [])
1123 -----------------------------------------------------------------------------
1124 -- Functions to generate functions dealing with vectors.
1125 -----------------------------------------------------------------------------
1127 -- Returns the VHDLId of the vector function with the given name for the given
1128 -- element type. Generates -- this function if needed.
1129 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1130 vectorFunId el_ty fname = do
1131 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1132 -- TODO: Handle the Nothing case?
1133 elemTM_maybe <- vhdlTy error_msg el_ty
1134 let elemTM = Maybe.fromMaybe
1135 (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1137 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1138 -- the VHDLState or something.
1139 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1140 typefuns <- MonadState.get tsTypeFuns
1141 el_htype <- mkHType error_msg el_ty
1142 case Map.lookup (UVecType el_htype, fname) typefuns of
1143 -- Function already generated, just return it
1144 Just (id, _) -> return id
1145 -- Function not generated yet, generate it
1147 let functions = genUnconsVectorFuns elemTM vectorTM
1148 case lookup fname functions of
1150 MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1151 mapM_ (vectorFunId el_ty) (snd body)
1153 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1155 function_id = mkVHDLExtId fname
1157 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1158 -> AST.TypeMark -- ^ type of the vector
1159 -> [(String, (AST.SubProgBody, [String]))]
1160 genUnconsVectorFuns elemTM vectorTM =
1161 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
1162 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1163 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
1164 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
1165 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1166 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
1167 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
1168 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1169 , (emptyId, (AST.SubProgBody emptySpec [AST.SPVD emptyVar] [emptyExpr],[]))
1170 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1171 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
1172 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
1173 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1174 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1175 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1176 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1177 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1178 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1179 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1180 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1181 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1184 ixPar = AST.unsafeVHDLBasicId "ix"
1185 vecPar = AST.unsafeVHDLBasicId "vec"
1186 vec1Par = AST.unsafeVHDLBasicId "vec1"
1187 vec2Par = AST.unsafeVHDLBasicId "vec2"
1188 nPar = AST.unsafeVHDLBasicId "n"
1189 leftPar = AST.unsafeVHDLBasicId "nLeft"
1190 rightPar = AST.unsafeVHDLBasicId "nRight"
1191 iId = AST.unsafeVHDLBasicId "i"
1193 aPar = AST.unsafeVHDLBasicId "a"
1194 fPar = AST.unsafeVHDLBasicId "f"
1195 sPar = AST.unsafeVHDLBasicId "s"
1196 resId = AST.unsafeVHDLBasicId "res"
1197 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1198 AST.IfaceVarDec ixPar unsignedTM] elemTM
1199 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1200 (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1201 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
1202 , AST.IfaceVarDec iPar unsignedTM
1203 , AST.IfaceVarDec aPar elemTM
1205 -- variable res : fsvec_x (0 to vec'length-1);
1208 (AST.SubtypeIn vectorTM
1209 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1210 [AST.ToRange (AST.PrimLit "0")
1211 (AST.PrimName (AST.NAttribute $
1212 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1213 (AST.PrimLit "1")) ]))
1215 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1216 replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1217 replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1218 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1219 vecSlice init last = AST.PrimName (AST.NSlice
1221 (AST.NSimple vecPar)
1222 (AST.ToRange init last)))
1223 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1224 -- return vec(vec'length-1);
1225 lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1226 (AST.NSimple vecPar)
1227 [AST.PrimName (AST.NAttribute $
1228 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1229 AST.:-: AST.PrimLit "1"])))
1230 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1231 -- variable res : fsvec_x (0 to vec'length-2);
1234 (AST.SubtypeIn vectorTM
1235 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1236 [AST.ToRange (AST.PrimLit "0")
1237 (AST.PrimName (AST.NAttribute $
1238 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1239 (AST.PrimLit "2")) ]))
1241 -- resAST.:= vec(0 to vec'length-2)
1242 initExpr = AST.NSimple resId AST.:= (vecSlice
1244 (AST.PrimName (AST.NAttribute $
1245 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1246 AST.:-: AST.PrimLit "2"))
1247 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1248 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
1249 AST.IfaceVarDec rightPar naturalTM ] naturalTM
1250 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1251 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1253 (Just $ AST.Else [minimumExprRet])
1254 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1255 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
1256 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1257 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1258 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1259 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1260 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1261 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1264 (AST.SubtypeIn vectorTM
1265 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1266 [AST.ToRange (AST.PrimLit "0")
1268 (AST.PrimLit "1")) ]))
1270 -- res AST.:= vec(0 to n-1)
1271 takeExpr = AST.NSimple resId AST.:=
1272 (vecSlice (AST.PrimLit "0")
1273 (minLength AST.:-: AST.PrimLit "1"))
1274 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1275 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
1276 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1277 -- variable res : fsvec_x (0 to vec'length-n-1);
1280 (AST.SubtypeIn vectorTM
1281 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1282 [AST.ToRange (AST.PrimLit "0")
1283 (AST.PrimName (AST.NAttribute $
1284 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1285 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1287 -- res AST.:= vec(n to vec'length-1)
1288 dropExpr = AST.NSimple resId AST.:= (vecSlice
1289 (AST.PrimName $ AST.NSimple nPar)
1290 (AST.PrimName (AST.NAttribute $
1291 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1292 AST.:-: AST.PrimLit "1"))
1293 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1294 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
1295 AST.IfaceVarDec vecPar vectorTM] vectorTM
1296 -- variable res : fsvec_x (0 to vec'length);
1299 (AST.SubtypeIn vectorTM
1300 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1301 [AST.ToRange (AST.PrimLit "0")
1302 (AST.PrimName (AST.NAttribute $
1303 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1305 plusgtExpr = AST.NSimple resId AST.:=
1306 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1307 (AST.PrimName $ AST.NSimple vecPar))
1308 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1309 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1312 (AST.SubtypeIn vectorTM
1313 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1314 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1316 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1317 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1319 -- variable res : fsvec_x (0 to 0) := (others => a);
1322 (AST.SubtypeIn vectorTM
1323 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1324 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1325 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1326 (AST.PrimName $ AST.NSimple aPar)])
1327 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1328 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
1329 AST.IfaceVarDec aPar elemTM ] vectorTM
1330 -- variable res : fsvec_x (0 to n-1) := (others => a);
1333 (AST.SubtypeIn vectorTM
1334 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1335 [AST.ToRange (AST.PrimLit "0")
1336 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1337 (AST.PrimLit "1")) ]))
1338 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1339 (AST.PrimName $ AST.NSimple aPar)])
1341 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1342 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
1343 AST.IfaceVarDec sPar naturalTM,
1344 AST.IfaceVarDec nPar naturalTM,
1345 AST.IfaceVarDec vecPar vectorTM ] vectorTM
1346 -- variable res : fsvec_x (0 to n-1);
1349 (AST.SubtypeIn vectorTM
1350 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1351 [AST.ToRange (AST.PrimLit "0")
1352 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1353 (AST.PrimLit "1")) ])
1356 -- for i res'range loop
1357 -- res(i) := vec(f+i*s);
1359 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1360 -- res(i) := vec(f+i*s);
1361 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1362 (AST.PrimName (AST.NSimple iId) AST.:*:
1363 AST.PrimName (AST.NSimple sPar)) in
1364 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1365 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1367 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1368 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1369 AST.IfaceVarDec aPar elemTM] vectorTM
1370 -- variable res : fsvec_x (0 to vec'length);
1373 (AST.SubtypeIn vectorTM
1374 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1375 [AST.ToRange (AST.PrimLit "0")
1376 (AST.PrimName (AST.NAttribute $
1377 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1379 ltplusExpr = AST.NSimple resId AST.:=
1380 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1381 (AST.PrimName $ AST.NSimple aPar))
1382 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1383 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1384 AST.IfaceVarDec vec2Par vectorTM]
1386 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1389 (AST.SubtypeIn vectorTM
1390 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1391 [AST.ToRange (AST.PrimLit "0")
1392 (AST.PrimName (AST.NAttribute $
1393 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1394 AST.PrimName (AST.NAttribute $
1395 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1398 plusplusExpr = AST.NSimple resId AST.:=
1399 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1400 (AST.PrimName $ AST.NSimple vec2Par))
1401 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1402 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1403 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1404 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1405 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1406 AST.IfaceVarDec aPar elemTM ] vectorTM
1407 -- variable res : fsvec_x (0 to vec'length-1);
1410 (AST.SubtypeIn vectorTM
1411 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1412 [AST.ToRange (AST.PrimLit "0")
1413 (AST.PrimName (AST.NAttribute $
1414 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1415 (AST.PrimLit "1")) ]))
1417 -- res := a & init(vec)
1418 shiftlExpr = AST.NSimple resId AST.:=
1419 (AST.PrimName (AST.NSimple aPar) AST.:&:
1420 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1421 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1422 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1423 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1424 AST.IfaceVarDec aPar elemTM ] vectorTM
1425 -- variable res : fsvec_x (0 to vec'length-1);
1428 (AST.SubtypeIn vectorTM
1429 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1430 [AST.ToRange (AST.PrimLit "0")
1431 (AST.PrimName (AST.NAttribute $
1432 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1433 (AST.PrimLit "1")) ]))
1435 -- res := tail(vec) & a
1436 shiftrExpr = AST.NSimple resId AST.:=
1437 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1438 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1439 (AST.PrimName (AST.NSimple aPar)))
1441 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1442 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1443 -- return vec'length = 0
1444 nullExpr = AST.ReturnSm (Just $
1445 AST.PrimName (AST.NAttribute $
1446 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1448 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1449 -- variable res : fsvec_x (0 to vec'length-1);
1452 (AST.SubtypeIn vectorTM
1453 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1454 [AST.ToRange (AST.PrimLit "0")
1455 (AST.PrimName (AST.NAttribute $
1456 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1457 (AST.PrimLit "1")) ]))
1459 -- if null(vec) then res := vec else res := last(vec) & init(vec)
1460 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1461 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1462 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1464 (Just $ AST.Else [rotlExprRet])
1466 AST.NSimple resId AST.:=
1467 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1468 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1469 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1470 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1471 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1472 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1473 -- variable res : fsvec_x (0 to vec'length-1);
1476 (AST.SubtypeIn vectorTM
1477 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1478 [AST.ToRange (AST.PrimLit "0")
1479 (AST.PrimName (AST.NAttribute $
1480 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1481 (AST.PrimLit "1")) ]))
1483 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1484 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1485 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1486 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1488 (Just $ AST.Else [rotrExprRet])
1490 AST.NSimple resId AST.:=
1491 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1492 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1493 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1494 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1495 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1496 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1499 (AST.SubtypeIn vectorTM
1500 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1501 [AST.ToRange (AST.PrimLit "0")
1502 (AST.PrimName (AST.NAttribute $
1503 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1504 (AST.PrimLit "1")) ]))
1506 -- for i in 0 to res'range loop
1507 -- res(vec'length-i-1) := vec(i);
1510 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1511 -- res(vec'length-i-1) := vec(i);
1512 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1513 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1514 [AST.PrimName $ AST.NSimple iId]))
1515 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1516 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1517 AST.PrimName (AST.NSimple iId) AST.:-:
1520 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1523 -----------------------------------------------------------------------------
1524 -- A table of builtin functions
1525 -----------------------------------------------------------------------------
1527 -- A function that generates VHDL for a builtin function
1528 type BuiltinBuilder =
1529 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1530 -> CoreSyn.CoreBndr -- ^ The function called
1531 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1532 -- dictionary arguments).
1533 -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1534 -- ^ The corresponding VHDL concurrent statements and entities
1537 -- A map of a builtin function to VHDL function builder
1538 type NameTable = Map.Map String (Int, BuiltinBuilder )
1540 -- | The builtin functions we support. Maps a name to an argument count and a
1541 -- builder function.
1542 globalNameTable :: NameTable
1543 globalNameTable = Map.fromList
1544 [ (exId , (2, genFCall True ) )
1545 , (replaceId , (3, genFCall False ) )
1546 , (headId , (1, genFCall True ) )
1547 , (lastId , (1, genFCall True ) )
1548 , (tailId , (1, genFCall False ) )
1549 , (initId , (1, genFCall False ) )
1550 , (takeId , (2, genFCall False ) )
1551 , (dropId , (2, genFCall False ) )
1552 , (selId , (4, genFCall False ) )
1553 , (plusgtId , (2, genFCall False ) )
1554 , (ltplusId , (2, genFCall False ) )
1555 , (plusplusId , (2, genFCall False ) )
1556 , (mapId , (2, genMap ) )
1557 , (zipWithId , (3, genZipWith ) )
1558 , (foldlId , (3, genFoldl ) )
1559 , (foldrId , (3, genFoldr ) )
1560 , (zipId , (2, genZip ) )
1561 , (unzipId , (1, genUnzip ) )
1562 , (shiftlId , (2, genFCall False ) )
1563 , (shiftrId , (2, genFCall False ) )
1564 , (rotlId , (1, genFCall False ) )
1565 , (rotrId , (1, genFCall False ) )
1566 , (concatId , (1, genConcat ) )
1567 , (reverseId , (1, genFCall False ) )
1568 , (iteratenId , (3, genIteraten ) )
1569 , (iterateId , (2, genIterate ) )
1570 , (generatenId , (3, genGeneraten ) )
1571 , (generateId , (2, genGenerate ) )
1572 , (emptyId , (0, genFCall False ) )
1573 , (singletonId , (1, genFCall False ) )
1574 , (copynId , (2, genFCall False ) )
1575 , (copyId , (1, genCopy ) )
1576 , (lengthTId , (1, genFCall False ) )
1577 , (nullId , (1, genFCall False ) )
1578 , (hwxorId , (2, genOperator2 AST.Xor ) )
1579 , (hwandId , (2, genOperator2 AST.And ) )
1580 , (hworId , (2, genOperator2 AST.Or ) )
1581 , (hwnotId , (1, genOperator1 AST.Not ) )
1582 , (equalityId , (2, genOperator2 (AST.:=:) ) )
1583 , (inEqualityId , (2, genOperator2 (AST.:/=:) ) )
1584 , (ltId , (2, genOperator2 (AST.:<:) ) )
1585 , (lteqId , (2, genOperator2 (AST.:<=:) ) )
1586 , (gtId , (2, genOperator2 (AST.:>:) ) )
1587 , (gteqId , (2, genOperator2 (AST.:>=:) ) )
1588 , (boolOrId , (2, genOperator2 AST.Or ) )
1589 , (boolAndId , (2, genOperator2 AST.And ) )
1590 , (plusId , (2, genOperator2 (AST.:+:) ) )
1591 , (timesId , (2, genTimes ) )
1592 , (negateId , (1, genNegation ) )
1593 , (minusId , (2, genOperator2 (AST.:-:) ) )
1594 , (fromSizedWordId , (1, genFromSizedWord ) )
1595 , (fromIntegerId , (1, genFromInteger ) )
1596 , (resizeWordId , (1, genResize ) )
1597 , (resizeIntId , (1, genResize ) )
1598 , (sizedIntId , (1, genSizedInt ) )
1599 , (smallIntegerId , (1, genFromInteger ) )
1600 , (fstId , (1, genFst ) )
1601 , (sndId , (1, genSnd ) )
1602 , (blockRAMId , (5, genBlockRAM ) )
1603 , (splitId , (1, genSplit ) )
1604 --, (tfvecId , (1, genTFVec ) )
1605 , (minimumId , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))