1 {-# LANGUAGE PackageImports #-}
6 import qualified Control.Monad as Monad
7 import qualified Data.Map as Map
9 import qualified Data.Either as Either
10 import qualified Control.Monad.Trans.State as State
11 import qualified "transformers" Control.Monad.Identity as Identity
13 import Data.Accessor.MonadState as MonadState
17 import qualified ForSyDe.Backend.VHDL.AST as AST
23 import qualified IdInfo
24 import qualified Literal
26 import qualified TyCon
35 -----------------------------------------------------------------------------
36 -- Functions to generate VHDL for builtin functions
37 -----------------------------------------------------------------------------
39 -- | A function to wrap a builder-like function that expects its arguments to
41 genExprArgs wrap dst func args = do
42 args' <- eitherCoreOrExprArgs args
45 idM :: a -> VHDLSession a
48 eitherM :: (a -> m c) -> (b -> m c) -> Either a b -> m c
54 eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
55 eitherCoreOrExprArgs args = mapM (eitherM (\x -> MonadState.lift vsType $ (varToVHDLExpr (exprToVar x))) idM) args
57 -- | A function to wrap a builder-like function that expects its arguments to
60 (dst -> func -> [Var.Var] -> res)
61 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
62 genVarArgs wrap dst func args = wrap dst func args'
64 args' = map exprToVar exprargs
65 -- Check (rather crudely) that all arguments are CoreExprs
66 (exprargs, []) = Either.partitionEithers args
68 -- | A function to wrap a builder-like function that expects its arguments to
71 (dst -> func -> [Literal.Literal] -> res)
72 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
73 genLitArgs wrap dst func args = wrap dst func args'
75 args' = map exprToLit litargs
76 -- FIXME: Check if we were passed an CoreSyn.App
77 litargs = concat (map getLiterals exprargs)
78 (exprargs, []) = Either.partitionEithers args
80 -- | A function to wrap a builder-like function that produces an expression
81 -- and expects it to be assigned to the destination.
83 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
84 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
85 genExprRes wrap dst func args = do
86 expr <- wrap dst func args
87 return $ [mkUncondAssign dst expr]
89 -- | Generate a binary operator application. The first argument should be a
90 -- constructor from the AST.Expr type, e.g. AST.And.
91 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
92 genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
93 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
94 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
96 -- | Generate a unary operator application
97 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
98 genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
99 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
100 genOperator1' op _ f [arg] = return $ op arg
102 -- | Generate a unary operator application
103 genNegation :: BuiltinBuilder
104 genNegation = genVarArgs $ genExprRes genNegation'
105 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
106 genNegation' _ f [arg] = do
107 arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
108 let ty = Var.varType arg
109 let (tycon, args) = Type.splitTyConApp ty
110 let name = Name.getOccString (TyCon.tyConName tycon)
112 "SizedInt" -> return $ AST.Neg arg1
113 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
115 -- | Generate a function call from the destination binder, function name and a
116 -- list of expressions (its arguments)
117 genFCall :: Bool -> BuiltinBuilder
118 genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
119 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
120 genFCall' switch (Left res) f args = do
121 let fname = varToString f
122 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
123 id <- MonadState.lift vsType $ vectorFunId el_ty fname
124 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
125 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
126 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
128 genFromSizedWord :: BuiltinBuilder
129 genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
130 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
131 genFromSizedWord' (Left res) f args = do
132 let fname = varToString f
133 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
134 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
135 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
137 genResize :: BuiltinBuilder
138 genResize = genExprArgs $ genExprRes genResize'
139 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
140 genResize' (Left res) f [arg] = do {
141 ; let { ty = Var.varType res
142 ; (tycon, args) = Type.splitTyConApp ty
143 ; name = Name.getOccString (TyCon.tyConName tycon)
145 ; len <- case name of
146 "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
147 "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
148 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
149 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
151 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
153 -- FIXME: I'm calling genLitArgs which is very specific function,
154 -- which needs to be fixed as well
155 genFromInteger :: BuiltinBuilder
156 genFromInteger = genLitArgs $ genExprRes genFromInteger'
157 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
158 genFromInteger' (Left res) f lits = do {
159 ; let { ty = Var.varType res
160 ; (tycon, args) = Type.splitTyConApp ty
161 ; name = Name.getOccString (TyCon.tyConName tycon)
163 ; len <- case name of
164 "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
165 "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
166 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
167 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
168 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
171 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
174 -- | Generate a generate statement for the builtin function "map"
175 genMap :: BuiltinBuilder
176 genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
177 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
178 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
179 -- we must index it (which we couldn't if it was a VHDL Expr, since only
180 -- VHDLNames can be indexed).
181 -- Setup the generate scheme
182 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
183 -- TODO: Use something better than varToString
184 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
185 ; n_id = mkVHDLBasicId "n"
186 ; n_expr = idToVHDLExpr n_id
187 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
188 ; genScheme = AST.ForGn n_id range
189 -- Create the content of the generate statement: Applying the mapped_f to
190 -- each of the elements in arg, storing to each element in res
191 ; resname = mkIndexedName (varToVHDLName res) n_expr
192 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
193 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
194 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
196 ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
197 -- Return the generate statement
198 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
201 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
203 genZipWith :: BuiltinBuilder
204 genZipWith = genVarArgs genZipWith'
205 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
206 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
207 -- Setup the generate scheme
208 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
209 -- TODO: Use something better than varToString
210 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
211 ; n_id = mkVHDLBasicId "n"
212 ; n_expr = idToVHDLExpr n_id
213 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
214 ; genScheme = AST.ForGn n_id range
215 -- Create the content of the generate statement: Applying the zipped_f to
216 -- each of the elements in arg1 and arg2, storing to each element in res
217 ; resname = mkIndexedName (varToVHDLName res) n_expr
218 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
219 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
221 ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
222 -- Return the generate functions
223 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
226 genFoldl :: BuiltinBuilder
227 genFoldl = genFold True
229 genFoldr :: BuiltinBuilder
230 genFoldr = genFold False
232 genFold :: Bool -> BuiltinBuilder
233 genFold left = genVarArgs (genFold' left)
235 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
236 genFold' left res f args@[folded_f , start ,vec]= do
237 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
238 genFold'' len left res f args
240 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
241 -- Special case for an empty input vector, just assign start to res
242 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
243 arg <- MonadState.lift vsType $ varToVHDLExpr start
244 return [mkUncondAssign (Left res) arg]
246 genFold'' len left (Left res) f [folded_f, start, vec] = do
248 --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
249 -- An expression for len-1
250 let len_min_expr = (AST.PrimLit $ show (len-1))
251 -- evec is (TFVec n), so it still needs an element type
252 let (nvec, _) = splitAppTy (Var.varType vec)
253 -- Put the type of the start value in nvec, this will be the type of our
255 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
256 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
257 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
258 -- Setup the generate scheme
259 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
260 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
261 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
262 else AST.DownRange len_min_expr (AST.PrimLit "0")
263 let gen_scheme = AST.ForGn n_id gen_range
264 -- Make the intermediate vector
265 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
266 -- Create the generate statement
267 cells <- sequence [genFirstCell, genOtherCell]
268 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
269 -- Assign tmp[len-1] or tmp[0] to res
270 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
271 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
272 (mkIndexedName tmp_name (AST.PrimLit "0")))
273 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
274 return [AST.CSBSm block]
276 -- An id for the counter
277 n_id = mkVHDLBasicId "n"
278 n_cur = idToVHDLExpr n_id
279 -- An expression for previous n
280 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
281 else (n_cur AST.:+: (AST.PrimLit "1"))
282 -- An id for the tmp result vector
283 tmp_id = mkVHDLBasicId "tmp"
284 tmp_name = AST.NSimple tmp_id
285 -- Generate parts of the fold
286 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
288 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
289 let cond_label = mkVHDLExtId "firstcell"
290 -- if n == 0 or n == len-1
291 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
292 else (AST.PrimLit $ show (len-1)))
293 -- Output to tmp[current n]
294 let resname = mkIndexedName tmp_name n_cur
296 argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
297 -- Input from vec[current n]
298 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
299 app_concsms <- genApplication (Right resname) folded_f ( if left then
300 [Right argexpr1, Right argexpr2]
302 [Right argexpr2, Right argexpr1]
304 -- Return the conditional generate part
305 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
308 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
309 let cond_label = mkVHDLExtId "othercell"
310 -- if n > 0 or n < len-1
311 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
312 else (AST.PrimLit $ show (len-1)))
313 -- Output to tmp[current n]
314 let resname = mkIndexedName tmp_name n_cur
315 -- Input from tmp[previous n]
316 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
317 -- Input from vec[current n]
318 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
319 app_concsms <- genApplication (Right resname) folded_f ( if left then
320 [Right argexpr1, Right argexpr2]
322 [Right argexpr2, Right argexpr1]
324 -- Return the conditional generate part
325 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
327 -- | Generate a generate statement for the builtin function "zip"
328 genZip :: BuiltinBuilder
329 genZip = genVarArgs genZip'
330 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
331 genZip' (Left res) f args@[arg1, arg2] = do {
332 -- Setup the generate scheme
333 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
334 -- TODO: Use something better than varToString
335 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
336 ; n_id = mkVHDLBasicId "n"
337 ; n_expr = idToVHDLExpr n_id
338 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
339 ; genScheme = AST.ForGn n_id range
340 ; resname' = mkIndexedName (varToVHDLName res) n_expr
341 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
342 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
344 ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
345 ; let { resnameA = mkSelectedName resname' (labels!!0)
346 ; resnameB = mkSelectedName resname' (labels!!1)
347 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
348 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
350 -- Return the generate functions
351 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
354 -- | Generate a generate statement for the builtin function "unzip"
355 genUnzip :: BuiltinBuilder
356 genUnzip = genVarArgs genUnzip'
357 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
358 genUnzip' (Left res) f args@[arg] = do {
359 -- Setup the generate scheme
360 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
361 -- TODO: Use something better than varToString
362 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
363 ; n_id = mkVHDLBasicId "n"
364 ; n_expr = idToVHDLExpr n_id
365 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
366 ; genScheme = AST.ForGn n_id range
367 ; resname' = varToVHDLName res
368 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
370 ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
371 ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
372 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
373 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
374 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
375 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
376 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
377 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
379 -- Return the generate functions
380 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
383 genCopy :: BuiltinBuilder
384 genCopy = genVarArgs genCopy'
385 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
386 genCopy' (Left res) f args@[arg] =
388 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
389 (AST.PrimName $ (varToVHDLName arg))]
390 out_assign = mkUncondAssign (Left res) resExpr
394 genConcat :: BuiltinBuilder
395 genConcat = genVarArgs genConcat'
396 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
397 genConcat' (Left res) f args@[arg] = do {
398 -- Setup the generate scheme
399 ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
400 ; let (_, nvec) = splitAppTy (Var.varType arg)
401 ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
402 -- TODO: Use something better than varToString
403 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
404 ; n_id = mkVHDLBasicId "n"
405 ; n_expr = idToVHDLExpr n_id
406 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
407 ; genScheme = AST.ForGn n_id range
408 -- Create the content of the generate statement: Applying the mapped_f to
409 -- each of the elements in arg, storing to each element in res
410 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
411 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
412 ; resname = vecSlice fromRange toRange
413 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
414 ; out_assign = mkUncondAssign (Right resname) argexpr
416 -- Return the generate statement
417 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
420 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
421 (AST.ToRange init last))
423 genIteraten :: BuiltinBuilder
424 genIteraten dst f args = genIterate dst f (tail args)
426 genIterate :: BuiltinBuilder
427 genIterate = genIterateOrGenerate True
429 genGeneraten :: BuiltinBuilder
430 genGeneraten dst f args = genGenerate dst f (tail args)
432 genGenerate :: BuiltinBuilder
433 genGenerate = genIterateOrGenerate False
435 genIterateOrGenerate :: Bool -> BuiltinBuilder
436 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
438 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
439 genIterateOrGenerate' iter (Left res) f args = do
440 len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
441 genIterateOrGenerate'' len iter (Left res) f args
443 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
444 -- Special case for an empty input vector, just assign start to res
445 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
447 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
449 -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
450 -- An expression for len-1
451 let len_min_expr = (AST.PrimLit $ show (len-1))
452 -- -- evec is (TFVec n), so it still needs an element type
453 -- let (nvec, _) = splitAppTy (Var.varType vec)
454 -- -- Put the type of the start value in nvec, this will be the type of our
455 -- -- temporary vector
456 let tmp_ty = Var.varType res
457 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
458 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
459 -- Setup the generate scheme
460 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
461 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
462 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
463 let gen_scheme = AST.ForGn n_id gen_range
464 -- Make the intermediate vector
465 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
466 -- Create the generate statement
467 cells <- sequence [genFirstCell, genOtherCell]
468 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
469 -- Assign tmp[len-1] or tmp[0] to res
470 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
471 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
472 return [AST.CSBSm block]
474 -- An id for the counter
475 n_id = mkVHDLBasicId "n"
476 n_cur = idToVHDLExpr n_id
477 -- An expression for previous n
478 n_prev = n_cur AST.:-: (AST.PrimLit "1")
479 -- An id for the tmp result vector
480 tmp_id = mkVHDLBasicId "tmp"
481 tmp_name = AST.NSimple tmp_id
482 -- Generate parts of the fold
483 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
485 let cond_label = mkVHDLExtId "firstcell"
486 -- if n == 0 or n == len-1
487 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
488 -- Output to tmp[current n]
489 let resname = mkIndexedName tmp_name n_cur
491 argexpr <- MonadState.lift vsType $ varToVHDLExpr start
492 let startassign = mkUncondAssign (Right resname) argexpr
493 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
494 -- Return the conditional generate part
495 return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
502 let cond_label = mkVHDLExtId "othercell"
503 -- if n > 0 or n < len-1
504 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
505 -- Output to tmp[current n]
506 let resname = mkIndexedName tmp_name n_cur
507 -- Input from tmp[previous n]
508 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
509 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
510 -- Return the conditional generate part
511 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
514 -----------------------------------------------------------------------------
515 -- Function to generate VHDL for applications
516 -----------------------------------------------------------------------------
518 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
519 -> CoreSyn.CoreBndr -- ^ The function to apply
520 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
521 -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
522 genApplication dst f args = do
523 case Var.globalIdVarDetails f of
524 IdInfo.DataConWorkId dc -> case dst of
525 -- It's a datacon. Create a record from its arguments.
527 -- We have the bndr, so we can get at the type
528 labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
529 args' <- eitherCoreOrExprArgs args
530 return $ zipWith mkassign labels $ args'
532 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
534 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
535 mkUncondAssign (Right sel_name) arg
536 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
537 IdInfo.VanillaGlobal -> do
538 -- It's a global value imported from elsewhere. These can be builtin
539 -- functions. Look up the function name in the name table and execute
540 -- the associated builder if there is any and the argument count matches
541 -- (this should always be the case if it typechecks, but just to be
543 case (Map.lookup (varToString f) globalNameTable) of
544 Just (arg_count, builder) ->
545 if length args == arg_count then
548 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
549 Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
550 IdInfo.NotGlobalId -> do
551 signatures <- getA vsSignatures
552 -- This is a local id, so it should be a function whose definition we
553 -- have and which can be turned into a component instantiation.
554 case (Map.lookup f signatures) of
556 args' <- eitherCoreOrExprArgs args
557 -- We have a signature, this is a top level binding. Generate a
558 -- component instantiation.
559 let entity_id = ent_id signature
560 -- TODO: Using show here isn't really pretty, but we'll need some
561 -- unique-ish value...
562 let label = "comp_ins_" ++ (either show prettyShow) dst
563 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
564 return [mkComponentInst label entity_id portmaps]
566 -- No signature, so this must be a local variable reference. It
567 -- should have a representable type (and thus, no arguments) and a
568 -- signal should be generated for it. Just generate an
569 -- unconditional assignment here.
570 f' <- MonadState.lift vsType $ varToVHDLExpr f
571 return $ [mkUncondAssign dst f']
573 IdInfo.ClassOpId cls -> do
574 -- FIXME: Not looking for what instance this class op is called for
575 -- Is quite stupid of course.
576 case (Map.lookup (varToString f) globalNameTable) of
577 Just (arg_count, builder) ->
578 if length args == arg_count then
581 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
582 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
583 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
585 -----------------------------------------------------------------------------
586 -- Functions to generate functions dealing with vectors.
587 -----------------------------------------------------------------------------
589 -- Returns the VHDLId of the vector function with the given name for the given
590 -- element type. Generates -- this function if needed.
591 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
592 vectorFunId el_ty fname = do
593 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
594 elemTM <- vhdl_ty error_msg el_ty
595 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
596 -- the VHDLState or something.
597 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
598 typefuns <- getA vsTypeFuns
599 case Map.lookup (OrdType el_ty, fname) typefuns of
600 -- Function already generated, just return it
601 Just (id, _) -> return id
602 -- Function not generated yet, generate it
604 let functions = genUnconsVectorFuns elemTM vectorTM
605 case lookup fname functions of
607 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
608 mapM_ (vectorFunId el_ty) (snd body)
610 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
612 function_id = mkVHDLExtId fname
614 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
615 -> AST.TypeMark -- ^ type of the vector
616 -> [(String, (AST.SubProgBody, [String]))]
617 genUnconsVectorFuns elemTM vectorTM =
618 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
619 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
620 , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
621 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
622 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
623 , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
624 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
625 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
626 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
627 , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
628 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
629 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
630 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
631 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
632 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
633 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
634 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
635 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
636 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
637 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
638 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
639 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
642 ixPar = AST.unsafeVHDLBasicId "ix"
643 vecPar = AST.unsafeVHDLBasicId "vec"
644 vec1Par = AST.unsafeVHDLBasicId "vec1"
645 vec2Par = AST.unsafeVHDLBasicId "vec2"
646 nPar = AST.unsafeVHDLBasicId "n"
647 iId = AST.unsafeVHDLBasicId "i"
649 aPar = AST.unsafeVHDLBasicId "a"
650 fPar = AST.unsafeVHDLBasicId "f"
651 sPar = AST.unsafeVHDLBasicId "s"
652 resId = AST.unsafeVHDLBasicId "res"
653 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
654 AST.IfaceVarDec ixPar naturalTM] elemTM
655 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
656 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
658 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
659 , AST.IfaceVarDec iPar naturalTM
660 , AST.IfaceVarDec aPar elemTM
662 -- variable res : fsvec_x (0 to vec'length-1);
665 (AST.SubtypeIn vectorTM
666 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
667 [AST.ToRange (AST.PrimLit "0")
668 (AST.PrimName (AST.NAttribute $
669 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
670 (AST.PrimLit "1")) ]))
672 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
673 replaceExpr = AST.NSimple resId AST.:=
674 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
675 AST.PrimName (AST.NSimple aPar) AST.:&:
676 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
677 ((AST.PrimName (AST.NAttribute $
678 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
679 AST.:-: AST.PrimLit "1"))
680 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
681 vecSlice init last = AST.PrimName (AST.NSlice
684 (AST.ToRange init last)))
685 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
687 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
688 (AST.NSimple vecPar) [AST.PrimLit "0"])))
689 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
690 -- return vec(vec'length-1);
691 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
693 [AST.PrimName (AST.NAttribute $
694 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
695 AST.:-: AST.PrimLit "1"])))
696 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
697 -- variable res : fsvec_x (0 to vec'length-2);
700 (AST.SubtypeIn vectorTM
701 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
702 [AST.ToRange (AST.PrimLit "0")
703 (AST.PrimName (AST.NAttribute $
704 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
705 (AST.PrimLit "2")) ]))
707 -- resAST.:= vec(0 to vec'length-2)
708 initExpr = AST.NSimple resId AST.:= (vecSlice
710 (AST.PrimName (AST.NAttribute $
711 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
712 AST.:-: AST.PrimLit "2"))
713 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
714 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
715 -- variable res : fsvec_x (0 to vec'length-2);
718 (AST.SubtypeIn vectorTM
719 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
720 [AST.ToRange (AST.PrimLit "0")
721 (AST.PrimName (AST.NAttribute $
722 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
723 (AST.PrimLit "2")) ]))
725 -- res AST.:= vec(1 to vec'length-1)
726 tailExpr = AST.NSimple resId AST.:= (vecSlice
728 (AST.PrimName (AST.NAttribute $
729 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
730 AST.:-: AST.PrimLit "1"))
731 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
732 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
733 AST.IfaceVarDec vecPar vectorTM ] vectorTM
734 -- variable res : fsvec_x (0 to n-1);
737 (AST.SubtypeIn vectorTM
738 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
739 [AST.ToRange (AST.PrimLit "0")
740 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
741 (AST.PrimLit "1")) ]))
743 -- res AST.:= vec(0 to n-1)
744 takeExpr = AST.NSimple resId AST.:=
745 (vecSlice (AST.PrimLit "1")
746 (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
747 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
748 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
749 AST.IfaceVarDec vecPar vectorTM ] vectorTM
750 -- variable res : fsvec_x (0 to vec'length-n-1);
753 (AST.SubtypeIn vectorTM
754 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
755 [AST.ToRange (AST.PrimLit "0")
756 (AST.PrimName (AST.NAttribute $
757 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
758 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
760 -- res AST.:= vec(n to vec'length-1)
761 dropExpr = AST.NSimple resId AST.:= (vecSlice
762 (AST.PrimName $ AST.NSimple nPar)
763 (AST.PrimName (AST.NAttribute $
764 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
765 AST.:-: AST.PrimLit "1"))
766 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
767 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
768 AST.IfaceVarDec vecPar vectorTM] vectorTM
769 -- variable res : fsvec_x (0 to vec'length);
772 (AST.SubtypeIn vectorTM
773 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
774 [AST.ToRange (AST.PrimLit "0")
775 (AST.PrimName (AST.NAttribute $
776 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
778 plusgtExpr = AST.NSimple resId AST.:=
779 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
780 (AST.PrimName $ AST.NSimple vecPar))
781 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
782 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
785 (AST.SubtypeIn vectorTM Nothing)
786 (Just $ AST.PrimLit "\"\"")
787 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
788 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
790 -- variable res : fsvec_x (0 to 0) := (others => a);
793 (AST.SubtypeIn vectorTM
794 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
795 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
796 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
797 (AST.PrimName $ AST.NSimple aPar)])
798 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
799 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
800 AST.IfaceVarDec aPar elemTM ] vectorTM
801 -- variable res : fsvec_x (0 to n-1) := (others => a);
804 (AST.SubtypeIn vectorTM
805 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
806 [AST.ToRange (AST.PrimLit "0")
807 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
808 (AST.PrimLit "1")) ]))
809 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
810 (AST.PrimName $ AST.NSimple aPar)])
812 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
813 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
814 AST.IfaceVarDec sPar naturalTM,
815 AST.IfaceVarDec nPar naturalTM,
816 AST.IfaceVarDec vecPar vectorTM ] vectorTM
817 -- variable res : fsvec_x (0 to n-1);
820 (AST.SubtypeIn vectorTM
821 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
822 [AST.ToRange (AST.PrimLit "0")
823 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
824 (AST.PrimLit "1")) ])
827 -- for i res'range loop
828 -- res(i) := vec(f+i*s);
830 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
831 -- res(i) := vec(f+i*s);
832 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
833 (AST.PrimName (AST.NSimple iId) AST.:*:
834 AST.PrimName (AST.NSimple sPar)) in
835 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
836 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
838 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
839 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
840 AST.IfaceVarDec aPar elemTM] vectorTM
841 -- variable res : fsvec_x (0 to vec'length);
844 (AST.SubtypeIn vectorTM
845 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
846 [AST.ToRange (AST.PrimLit "0")
847 (AST.PrimName (AST.NAttribute $
848 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
850 ltplusExpr = AST.NSimple resId AST.:=
851 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
852 (AST.PrimName $ AST.NSimple aPar))
853 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
854 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
855 AST.IfaceVarDec vec2Par vectorTM]
857 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
860 (AST.SubtypeIn vectorTM
861 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
862 [AST.ToRange (AST.PrimLit "0")
863 (AST.PrimName (AST.NAttribute $
864 AST.AttribName (AST.NSimple vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
865 AST.PrimName (AST.NAttribute $
866 AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
869 plusplusExpr = AST.NSimple resId AST.:=
870 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
871 (AST.PrimName $ AST.NSimple vec2Par))
872 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
873 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
874 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
875 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
876 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
877 AST.IfaceVarDec aPar elemTM ] vectorTM
878 -- variable res : fsvec_x (0 to vec'length-1);
881 (AST.SubtypeIn vectorTM
882 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
883 [AST.ToRange (AST.PrimLit "0")
884 (AST.PrimName (AST.NAttribute $
885 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
886 (AST.PrimLit "1")) ]))
888 -- res := a & init(vec)
889 shiftlExpr = AST.NSimple resId AST.:=
890 (AST.PrimName (AST.NSimple aPar) AST.:&:
891 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
892 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
893 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
894 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
895 AST.IfaceVarDec aPar elemTM ] vectorTM
896 -- variable res : fsvec_x (0 to vec'length-1);
899 (AST.SubtypeIn vectorTM
900 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
901 [AST.ToRange (AST.PrimLit "0")
902 (AST.PrimName (AST.NAttribute $
903 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
904 (AST.PrimLit "1")) ]))
906 -- res := tail(vec) & a
907 shiftrExpr = AST.NSimple resId AST.:=
908 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
909 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
910 (AST.PrimName (AST.NSimple aPar)))
912 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
913 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
914 -- return vec'length = 0
915 nullExpr = AST.ReturnSm (Just $
916 AST.PrimName (AST.NAttribute $
917 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
919 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
920 -- variable res : fsvec_x (0 to vec'length-1);
923 (AST.SubtypeIn vectorTM
924 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
925 [AST.ToRange (AST.PrimLit "0")
926 (AST.PrimName (AST.NAttribute $
927 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
928 (AST.PrimLit "1")) ]))
930 -- if null(vec) then res := vec else res := last(vec) & init(vec)
931 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
932 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
933 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
935 (Just $ AST.Else [rotlExprRet])
937 AST.NSimple resId AST.:=
938 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
939 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
940 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
941 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
942 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
943 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
944 -- variable res : fsvec_x (0 to vec'length-1);
947 (AST.SubtypeIn vectorTM
948 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
949 [AST.ToRange (AST.PrimLit "0")
950 (AST.PrimName (AST.NAttribute $
951 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
952 (AST.PrimLit "1")) ]))
954 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
955 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
956 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
957 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
959 (Just $ AST.Else [rotrExprRet])
961 AST.NSimple resId AST.:=
962 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
963 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
964 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
965 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
966 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
967 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
970 (AST.SubtypeIn vectorTM
971 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
972 [AST.ToRange (AST.PrimLit "0")
973 (AST.PrimName (AST.NAttribute $
974 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
975 (AST.PrimLit "1")) ]))
977 -- for i in 0 to res'range loop
978 -- res(vec'length-i-1) := vec(i);
981 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
982 -- res(vec'length-i-1) := vec(i);
983 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
984 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
985 [AST.PrimName $ AST.NSimple iId]))
986 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
987 (mkVHDLBasicId lengthId) Nothing) AST.:-:
988 AST.PrimName (AST.NSimple iId) AST.:-:
991 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
993 -----------------------------------------------------------------------------
994 -- A table of builtin functions
995 -----------------------------------------------------------------------------
997 -- | The builtin functions we support. Maps a name to an argument count and a
999 globalNameTable :: NameTable
1000 globalNameTable = Map.fromList
1001 [ (exId , (2, genFCall False ) )
1002 , (replaceId , (3, genFCall False ) )
1003 , (headId , (1, genFCall True ) )
1004 , (lastId , (1, genFCall True ) )
1005 , (tailId , (1, genFCall False ) )
1006 , (initId , (1, genFCall False ) )
1007 , (takeId , (2, genFCall False ) )
1008 , (dropId , (2, genFCall False ) )
1009 , (selId , (4, genFCall False ) )
1010 , (plusgtId , (2, genFCall False ) )
1011 , (ltplusId , (2, genFCall False ) )
1012 , (plusplusId , (2, genFCall False ) )
1013 , (mapId , (2, genMap ) )
1014 , (zipWithId , (3, genZipWith ) )
1015 , (foldlId , (3, genFoldl ) )
1016 , (foldrId , (3, genFoldr ) )
1017 , (zipId , (2, genZip ) )
1018 , (unzipId , (1, genUnzip ) )
1019 , (shiftlId , (2, genFCall False ) )
1020 , (shiftrId , (2, genFCall False ) )
1021 , (rotlId , (1, genFCall False ) )
1022 , (rotrId , (1, genFCall False ) )
1023 , (concatId , (1, genConcat ) )
1024 , (reverseId , (1, genFCall False ) )
1025 , (iteratenId , (3, genIteraten ) )
1026 , (iterateId , (2, genIterate ) )
1027 , (generatenId , (3, genGeneraten ) )
1028 , (generateId , (2, genGenerate ) )
1029 , (emptyId , (0, genFCall False ) )
1030 , (singletonId , (1, genFCall False ) )
1031 , (copynId , (2, genFCall False ) )
1032 , (copyId , (1, genCopy ) )
1033 , (lengthTId , (1, genFCall False ) )
1034 , (nullId , (1, genFCall False ) )
1035 , (hwxorId , (2, genOperator2 AST.Xor ) )
1036 , (hwandId , (2, genOperator2 AST.And ) )
1037 , (hworId , (2, genOperator2 AST.Or ) )
1038 , (hwnotId , (1, genOperator1 AST.Not ) )
1039 , (plusId , (2, genOperator2 (AST.:+:) ) )
1040 , (timesId , (2, genOperator2 (AST.:*:) ) )
1041 , (negateId , (1, genNegation ) )
1042 , (minusId , (2, genOperator2 (AST.:-:) ) )
1043 , (fromSizedWordId , (1, genFromSizedWord ) )
1044 , (fromIntegerId , (1, genFromInteger ) )
1045 , (resizeId , (1, genResize ) )