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 -- FIXME: I'm calling genLitArgs which is very specific function,
138 -- which needs to be fixed as well
139 genFromInteger :: BuiltinBuilder
140 genFromInteger = genLitArgs $ genExprRes genFromInteger'
141 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
142 genFromInteger' (Left res) f lits = do {
143 ; let { ty = Var.varType res
144 ; (tycon, args) = Type.splitTyConApp ty
145 ; name = Name.getOccString (TyCon.tyConName tycon)
147 ; len <- case name of
148 "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
149 "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
150 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
151 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
152 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
155 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
158 -- | Generate a generate statement for the builtin function "map"
159 genMap :: BuiltinBuilder
160 genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
161 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
162 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
163 -- we must index it (which we couldn't if it was a VHDL Expr, since only
164 -- VHDLNames can be indexed).
165 -- Setup the generate scheme
166 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
167 -- TODO: Use something better than varToString
168 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
169 ; n_id = mkVHDLBasicId "n"
170 ; n_expr = idToVHDLExpr n_id
171 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
172 ; genScheme = AST.ForGn n_id range
173 -- Create the content of the generate statement: Applying the mapped_f to
174 -- each of the elements in arg, storing to each element in res
175 ; resname = mkIndexedName (varToVHDLName res) n_expr
176 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
177 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
178 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
180 ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
181 -- Return the generate statement
182 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
185 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
187 genZipWith :: BuiltinBuilder
188 genZipWith = genVarArgs genZipWith'
189 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
190 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
191 -- Setup the generate scheme
192 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
193 -- TODO: Use something better than varToString
194 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
195 ; n_id = mkVHDLBasicId "n"
196 ; n_expr = idToVHDLExpr n_id
197 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
198 ; genScheme = AST.ForGn n_id range
199 -- Create the content of the generate statement: Applying the zipped_f to
200 -- each of the elements in arg1 and arg2, storing to each element in res
201 ; resname = mkIndexedName (varToVHDLName res) n_expr
202 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
203 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
205 ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
206 -- Return the generate functions
207 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
210 genFoldl :: BuiltinBuilder
211 genFoldl = genFold True
213 genFoldr :: BuiltinBuilder
214 genFoldr = genFold False
216 genFold :: Bool -> BuiltinBuilder
217 genFold left = genVarArgs (genFold' left)
219 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
220 genFold' left res f args@[folded_f , start ,vec]= do
221 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
222 genFold'' len left res f args
224 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
225 -- Special case for an empty input vector, just assign start to res
226 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
227 arg <- MonadState.lift vsType $ varToVHDLExpr start
228 return [mkUncondAssign (Left res) arg]
230 genFold'' len left (Left res) f [folded_f, start, vec] = do
232 --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
233 -- An expression for len-1
234 let len_min_expr = (AST.PrimLit $ show (len-1))
235 -- evec is (TFVec n), so it still needs an element type
236 let (nvec, _) = splitAppTy (Var.varType vec)
237 -- Put the type of the start value in nvec, this will be the type of our
239 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
240 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
241 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
242 -- Setup the generate scheme
243 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
244 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
245 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
246 else AST.DownRange len_min_expr (AST.PrimLit "0")
247 let gen_scheme = AST.ForGn n_id gen_range
248 -- Make the intermediate vector
249 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
250 -- Create the generate statement
251 cells <- sequence [genFirstCell, genOtherCell]
252 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
253 -- Assign tmp[len-1] or tmp[0] to res
254 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
255 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
256 (mkIndexedName tmp_name (AST.PrimLit "0")))
257 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
258 return [AST.CSBSm block]
260 -- An id for the counter
261 n_id = mkVHDLBasicId "n"
262 n_cur = idToVHDLExpr n_id
263 -- An expression for previous n
264 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
265 else (n_cur AST.:+: (AST.PrimLit "1"))
266 -- An id for the tmp result vector
267 tmp_id = mkVHDLBasicId "tmp"
268 tmp_name = AST.NSimple tmp_id
269 -- Generate parts of the fold
270 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
272 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
273 let cond_label = mkVHDLExtId "firstcell"
274 -- if n == 0 or n == len-1
275 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
276 else (AST.PrimLit $ show (len-1)))
277 -- Output to tmp[current n]
278 let resname = mkIndexedName tmp_name n_cur
280 argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
281 -- Input from vec[current n]
282 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
283 app_concsms <- genApplication (Right resname) folded_f ( if left then
284 [Right argexpr1, Right argexpr2]
286 [Right argexpr2, Right argexpr1]
288 -- Return the conditional generate part
289 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
292 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
293 let cond_label = mkVHDLExtId "othercell"
294 -- if n > 0 or n < len-1
295 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
296 else (AST.PrimLit $ show (len-1)))
297 -- Output to tmp[current n]
298 let resname = mkIndexedName tmp_name n_cur
299 -- Input from tmp[previous n]
300 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
301 -- Input from vec[current n]
302 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
303 app_concsms <- genApplication (Right resname) folded_f ( if left then
304 [Right argexpr1, Right argexpr2]
306 [Right argexpr2, Right argexpr1]
308 -- Return the conditional generate part
309 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
311 -- | Generate a generate statement for the builtin function "zip"
312 genZip :: BuiltinBuilder
313 genZip = genVarArgs genZip'
314 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
315 genZip' (Left res) f args@[arg1, arg2] = do {
316 -- Setup the generate scheme
317 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
318 -- TODO: Use something better than varToString
319 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
320 ; n_id = mkVHDLBasicId "n"
321 ; n_expr = idToVHDLExpr n_id
322 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
323 ; genScheme = AST.ForGn n_id range
324 ; resname' = mkIndexedName (varToVHDLName res) n_expr
325 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
326 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
328 ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
329 ; let { resnameA = mkSelectedName resname' (labels!!0)
330 ; resnameB = mkSelectedName resname' (labels!!1)
331 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
332 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
334 -- Return the generate functions
335 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
338 -- | Generate a generate statement for the builtin function "unzip"
339 genUnzip :: BuiltinBuilder
340 genUnzip = genVarArgs genUnzip'
341 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
342 genUnzip' (Left res) f args@[arg] = do {
343 -- Setup the generate scheme
344 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
345 -- TODO: Use something better than varToString
346 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
347 ; n_id = mkVHDLBasicId "n"
348 ; n_expr = idToVHDLExpr n_id
349 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
350 ; genScheme = AST.ForGn n_id range
351 ; resname' = varToVHDLName res
352 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
354 ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
355 ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
356 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
357 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
358 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
359 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
360 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
361 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
363 -- Return the generate functions
364 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
367 genCopy :: BuiltinBuilder
368 genCopy = genVarArgs genCopy'
369 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
370 genCopy' (Left res) f args@[arg] =
372 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
373 (AST.PrimName $ (varToVHDLName arg))]
374 out_assign = mkUncondAssign (Left res) resExpr
378 genConcat :: BuiltinBuilder
379 genConcat = genVarArgs genConcat'
380 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
381 genConcat' (Left res) f args@[arg] = do {
382 -- Setup the generate scheme
383 ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
384 ; let (_, nvec) = splitAppTy (Var.varType arg)
385 ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
386 -- TODO: Use something better than varToString
387 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
388 ; n_id = mkVHDLBasicId "n"
389 ; n_expr = idToVHDLExpr n_id
390 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
391 ; genScheme = AST.ForGn n_id range
392 -- Create the content of the generate statement: Applying the mapped_f to
393 -- each of the elements in arg, storing to each element in res
394 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
395 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
396 ; resname = vecSlice fromRange toRange
397 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
398 ; out_assign = mkUncondAssign (Right resname) argexpr
400 -- Return the generate statement
401 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
404 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
405 (AST.ToRange init last))
407 genIteraten :: BuiltinBuilder
408 genIteraten dst f args = genIterate dst f (tail args)
410 genIterate :: BuiltinBuilder
411 genIterate = genIterateOrGenerate True
413 genGeneraten :: BuiltinBuilder
414 genGeneraten dst f args = genGenerate dst f (tail args)
416 genGenerate :: BuiltinBuilder
417 genGenerate = genIterateOrGenerate False
419 genIterateOrGenerate :: Bool -> BuiltinBuilder
420 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
422 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
423 genIterateOrGenerate' iter (Left res) f args = do
424 len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
425 genIterateOrGenerate'' len iter (Left res) f args
427 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
428 -- Special case for an empty input vector, just assign start to res
429 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
431 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
433 -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
434 -- An expression for len-1
435 let len_min_expr = (AST.PrimLit $ show (len-1))
436 -- -- evec is (TFVec n), so it still needs an element type
437 -- let (nvec, _) = splitAppTy (Var.varType vec)
438 -- -- Put the type of the start value in nvec, this will be the type of our
439 -- -- temporary vector
440 let tmp_ty = Var.varType res
441 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
442 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
443 -- Setup the generate scheme
444 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
445 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
446 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
447 let gen_scheme = AST.ForGn n_id gen_range
448 -- Make the intermediate vector
449 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
450 -- Create the generate statement
451 cells <- sequence [genFirstCell, genOtherCell]
452 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
453 -- Assign tmp[len-1] or tmp[0] to res
454 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
455 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
456 return [AST.CSBSm block]
458 -- An id for the counter
459 n_id = mkVHDLBasicId "n"
460 n_cur = idToVHDLExpr n_id
461 -- An expression for previous n
462 n_prev = n_cur AST.:-: (AST.PrimLit "1")
463 -- An id for the tmp result vector
464 tmp_id = mkVHDLBasicId "tmp"
465 tmp_name = AST.NSimple tmp_id
466 -- Generate parts of the fold
467 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
469 let cond_label = mkVHDLExtId "firstcell"
470 -- if n == 0 or n == len-1
471 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
472 -- Output to tmp[current n]
473 let resname = mkIndexedName tmp_name n_cur
475 argexpr <- MonadState.lift vsType $ varToVHDLExpr start
476 let startassign = mkUncondAssign (Right resname) argexpr
477 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
478 -- Return the conditional generate part
479 return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
486 let cond_label = mkVHDLExtId "othercell"
487 -- if n > 0 or n < len-1
488 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
489 -- Output to tmp[current n]
490 let resname = mkIndexedName tmp_name n_cur
491 -- Input from tmp[previous n]
492 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
493 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
494 -- Return the conditional generate part
495 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
498 -----------------------------------------------------------------------------
499 -- Function to generate VHDL for applications
500 -----------------------------------------------------------------------------
502 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
503 -> CoreSyn.CoreBndr -- ^ The function to apply
504 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
505 -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
506 genApplication dst f args = do
507 case Var.globalIdVarDetails f of
508 IdInfo.DataConWorkId dc -> case dst of
509 -- It's a datacon. Create a record from its arguments.
511 -- We have the bndr, so we can get at the type
512 labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
513 args' <- eitherCoreOrExprArgs args
514 return $ zipWith mkassign labels $ args'
516 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
518 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
519 mkUncondAssign (Right sel_name) arg
520 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
521 IdInfo.VanillaGlobal -> do
522 -- It's a global value imported from elsewhere. These can be builtin
523 -- functions. Look up the function name in the name table and execute
524 -- the associated builder if there is any and the argument count matches
525 -- (this should always be the case if it typechecks, but just to be
527 case (Map.lookup (varToString f) globalNameTable) of
528 Just (arg_count, builder) ->
529 if length args == arg_count then
532 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
533 Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
534 IdInfo.NotGlobalId -> do
535 signatures <- getA vsSignatures
536 -- This is a local id, so it should be a function whose definition we
537 -- have and which can be turned into a component instantiation.
538 case (Map.lookup f signatures) of
540 args' <- eitherCoreOrExprArgs args
541 -- We have a signature, this is a top level binding. Generate a
542 -- component instantiation.
543 let entity_id = ent_id signature
544 -- TODO: Using show here isn't really pretty, but we'll need some
545 -- unique-ish value...
546 let label = "comp_ins_" ++ (either show prettyShow) dst
547 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
548 return [mkComponentInst label entity_id portmaps]
550 -- No signature, so this must be a local variable reference. It
551 -- should have a representable type (and thus, no arguments) and a
552 -- signal should be generated for it. Just generate an
553 -- unconditional assignment here.
554 f' <- MonadState.lift vsType $ varToVHDLExpr f
555 return $ [mkUncondAssign dst f']
557 IdInfo.ClassOpId cls -> do
558 -- FIXME: Not looking for what instance this class op is called for
559 -- Is quite stupid of course.
560 case (Map.lookup (varToString f) globalNameTable) of
561 Just (arg_count, builder) ->
562 if length args == arg_count then
565 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
566 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
567 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
569 -----------------------------------------------------------------------------
570 -- Functions to generate functions dealing with vectors.
571 -----------------------------------------------------------------------------
573 -- Returns the VHDLId of the vector function with the given name for the given
574 -- element type. Generates -- this function if needed.
575 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
576 vectorFunId el_ty fname = do
577 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
578 elemTM <- vhdl_ty error_msg el_ty
579 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
580 -- the VHDLState or something.
581 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
582 typefuns <- getA vsTypeFuns
583 case Map.lookup (OrdType el_ty, fname) typefuns of
584 -- Function already generated, just return it
585 Just (id, _) -> return id
586 -- Function not generated yet, generate it
588 let functions = genUnconsVectorFuns elemTM vectorTM
589 case lookup fname functions of
591 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
592 mapM_ (vectorFunId el_ty) (snd body)
594 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
596 function_id = mkVHDLExtId fname
598 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
599 -> AST.TypeMark -- ^ type of the vector
600 -> [(String, (AST.SubProgBody, [String]))]
601 genUnconsVectorFuns elemTM vectorTM =
602 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
603 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
604 , (headId, (AST.SubProgBody headSpec [] [headExpr],[]))
605 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
606 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
607 , (tailId, (AST.SubProgBody tailSpec [AST.SPVD tailVar] [tailExpr, tailRet],[]))
608 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[]))
609 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
610 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
611 , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
612 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
613 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
614 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
615 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
616 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
617 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
618 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
619 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
620 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
621 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
622 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
623 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
626 ixPar = AST.unsafeVHDLBasicId "ix"
627 vecPar = AST.unsafeVHDLBasicId "vec"
628 vec1Par = AST.unsafeVHDLBasicId "vec1"
629 vec2Par = AST.unsafeVHDLBasicId "vec2"
630 nPar = AST.unsafeVHDLBasicId "n"
631 iId = AST.unsafeVHDLBasicId "i"
633 aPar = AST.unsafeVHDLBasicId "a"
634 fPar = AST.unsafeVHDLBasicId "f"
635 sPar = AST.unsafeVHDLBasicId "s"
636 resId = AST.unsafeVHDLBasicId "res"
637 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
638 AST.IfaceVarDec ixPar naturalTM] elemTM
639 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
640 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
642 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
643 , AST.IfaceVarDec iPar naturalTM
644 , AST.IfaceVarDec aPar elemTM
646 -- variable res : fsvec_x (0 to vec'length-1);
649 (AST.SubtypeIn vectorTM
650 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
651 [AST.ToRange (AST.PrimLit "0")
652 (AST.PrimName (AST.NAttribute $
653 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
654 (AST.PrimLit "1")) ]))
656 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
657 replaceExpr = AST.NSimple resId AST.:=
658 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
659 AST.PrimName (AST.NSimple aPar) AST.:&:
660 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
661 ((AST.PrimName (AST.NAttribute $
662 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
663 AST.:-: AST.PrimLit "1"))
664 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
665 vecSlice init last = AST.PrimName (AST.NSlice
668 (AST.ToRange init last)))
669 headSpec = AST.Function (mkVHDLExtId headId) [AST.IfaceVarDec vecPar vectorTM] elemTM
671 headExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
672 (AST.NSimple vecPar) [AST.PrimLit "0"])))
673 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
674 -- return vec(vec'length-1);
675 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
677 [AST.PrimName (AST.NAttribute $
678 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
679 AST.:-: AST.PrimLit "1"])))
680 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
681 -- variable res : fsvec_x (0 to vec'length-2);
684 (AST.SubtypeIn vectorTM
685 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
686 [AST.ToRange (AST.PrimLit "0")
687 (AST.PrimName (AST.NAttribute $
688 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
689 (AST.PrimLit "2")) ]))
691 -- resAST.:= vec(0 to vec'length-2)
692 initExpr = AST.NSimple resId AST.:= (vecSlice
694 (AST.PrimName (AST.NAttribute $
695 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
696 AST.:-: AST.PrimLit "2"))
697 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
698 tailSpec = AST.Function (mkVHDLExtId tailId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
699 -- variable res : fsvec_x (0 to vec'length-2);
702 (AST.SubtypeIn vectorTM
703 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
704 [AST.ToRange (AST.PrimLit "0")
705 (AST.PrimName (AST.NAttribute $
706 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
707 (AST.PrimLit "2")) ]))
709 -- res AST.:= vec(1 to vec'length-1)
710 tailExpr = AST.NSimple resId AST.:= (vecSlice
712 (AST.PrimName (AST.NAttribute $
713 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
714 AST.:-: AST.PrimLit "1"))
715 tailRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
716 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
717 AST.IfaceVarDec vecPar vectorTM ] vectorTM
718 -- variable res : fsvec_x (0 to n-1);
721 (AST.SubtypeIn vectorTM
722 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
723 [AST.ToRange (AST.PrimLit "0")
724 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
725 (AST.PrimLit "1")) ]))
727 -- res AST.:= vec(0 to n-1)
728 takeExpr = AST.NSimple resId AST.:=
729 (vecSlice (AST.PrimLit "1")
730 (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
731 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
732 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
733 AST.IfaceVarDec vecPar vectorTM ] vectorTM
734 -- variable res : fsvec_x (0 to vec'length-n-1);
737 (AST.SubtypeIn vectorTM
738 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
739 [AST.ToRange (AST.PrimLit "0")
740 (AST.PrimName (AST.NAttribute $
741 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
742 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
744 -- res AST.:= vec(n to vec'length-1)
745 dropExpr = AST.NSimple resId AST.:= (vecSlice
746 (AST.PrimName $ AST.NSimple nPar)
747 (AST.PrimName (AST.NAttribute $
748 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing)
749 AST.:-: AST.PrimLit "1"))
750 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
751 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
752 AST.IfaceVarDec vecPar vectorTM] vectorTM
753 -- variable res : fsvec_x (0 to vec'length);
756 (AST.SubtypeIn vectorTM
757 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
758 [AST.ToRange (AST.PrimLit "0")
759 (AST.PrimName (AST.NAttribute $
760 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
762 plusgtExpr = AST.NSimple resId AST.:=
763 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
764 (AST.PrimName $ AST.NSimple vecPar))
765 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
766 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
769 (AST.SubtypeIn vectorTM Nothing)
770 (Just $ AST.PrimLit "\"\"")
771 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
772 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
774 -- variable res : fsvec_x (0 to 0) := (others => a);
777 (AST.SubtypeIn vectorTM
778 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
779 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
780 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
781 (AST.PrimName $ AST.NSimple aPar)])
782 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
783 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
784 AST.IfaceVarDec aPar elemTM ] vectorTM
785 -- variable res : fsvec_x (0 to n-1) := (others => a);
788 (AST.SubtypeIn vectorTM
789 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
790 [AST.ToRange (AST.PrimLit "0")
791 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
792 (AST.PrimLit "1")) ]))
793 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
794 (AST.PrimName $ AST.NSimple aPar)])
796 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
797 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
798 AST.IfaceVarDec sPar naturalTM,
799 AST.IfaceVarDec nPar naturalTM,
800 AST.IfaceVarDec vecPar vectorTM ] vectorTM
801 -- variable res : fsvec_x (0 to n-1);
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")) ])
811 -- for i res'range loop
812 -- res(i) := vec(f+i*s);
814 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [selAssign]
815 -- res(i) := vec(f+i*s);
816 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
817 (AST.PrimName (AST.NSimple iId) AST.:*:
818 AST.PrimName (AST.NSimple sPar)) in
819 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
820 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
822 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
823 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
824 AST.IfaceVarDec aPar elemTM] vectorTM
825 -- variable res : fsvec_x (0 to vec'length);
828 (AST.SubtypeIn vectorTM
829 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
830 [AST.ToRange (AST.PrimLit "0")
831 (AST.PrimName (AST.NAttribute $
832 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))]))
834 ltplusExpr = AST.NSimple resId AST.:=
835 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
836 (AST.PrimName $ AST.NSimple aPar))
837 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
838 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
839 AST.IfaceVarDec vec2Par vectorTM]
841 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
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 vec1Par) (mkVHDLBasicId lengthId) Nothing) AST.:+:
849 AST.PrimName (AST.NAttribute $
850 AST.AttribName (AST.NSimple vec2Par) (mkVHDLBasicId lengthId) Nothing) AST.:-:
853 plusplusExpr = AST.NSimple resId AST.:=
854 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
855 (AST.PrimName $ AST.NSimple vec2Par))
856 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
857 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
858 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
859 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing))
860 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
861 AST.IfaceVarDec aPar elemTM ] vectorTM
862 -- variable res : fsvec_x (0 to vec'length-1);
865 (AST.SubtypeIn vectorTM
866 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
867 [AST.ToRange (AST.PrimLit "0")
868 (AST.PrimName (AST.NAttribute $
869 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
870 (AST.PrimLit "1")) ]))
872 -- res := a & init(vec)
873 shiftlExpr = AST.NSimple resId AST.:=
874 (AST.PrimName (AST.NSimple aPar) AST.:&:
875 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
876 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
877 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
878 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
879 AST.IfaceVarDec aPar elemTM ] vectorTM
880 -- variable res : fsvec_x (0 to vec'length-1);
883 (AST.SubtypeIn vectorTM
884 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
885 [AST.ToRange (AST.PrimLit "0")
886 (AST.PrimName (AST.NAttribute $
887 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
888 (AST.PrimLit "1")) ]))
890 -- res := tail(vec) & a
891 shiftrExpr = AST.NSimple resId AST.:=
892 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
893 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
894 (AST.PrimName (AST.NSimple aPar)))
896 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
897 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
898 -- return vec'length = 0
899 nullExpr = AST.ReturnSm (Just $
900 AST.PrimName (AST.NAttribute $
901 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:=:
903 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
904 -- variable res : fsvec_x (0 to vec'length-1);
907 (AST.SubtypeIn vectorTM
908 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
909 [AST.ToRange (AST.PrimLit "0")
910 (AST.PrimName (AST.NAttribute $
911 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
912 (AST.PrimLit "1")) ]))
914 -- if null(vec) then res := vec else res := last(vec) & init(vec)
915 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
916 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
917 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
919 (Just $ AST.Else [rotlExprRet])
921 AST.NSimple resId AST.:=
922 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
923 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
924 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
925 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
926 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
927 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
928 -- variable res : fsvec_x (0 to vec'length-1);
931 (AST.SubtypeIn vectorTM
932 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
933 [AST.ToRange (AST.PrimLit "0")
934 (AST.PrimName (AST.NAttribute $
935 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
936 (AST.PrimLit "1")) ]))
938 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
939 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
940 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
941 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
943 (Just $ AST.Else [rotrExprRet])
945 AST.NSimple resId AST.:=
946 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
947 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
948 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
949 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
950 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
951 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
954 (AST.SubtypeIn vectorTM
955 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
956 [AST.ToRange (AST.PrimLit "0")
957 (AST.PrimName (AST.NAttribute $
958 AST.AttribName (AST.NSimple vecPar) (mkVHDLBasicId lengthId) Nothing) AST.:-:
959 (AST.PrimLit "1")) ]))
961 -- for i in 0 to res'range loop
962 -- res(vec'length-i-1) := vec(i);
965 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) rangeId Nothing) [reverseAssign]
966 -- res(vec'length-i-1) := vec(i);
967 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
968 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
969 [AST.PrimName $ AST.NSimple iId]))
970 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
971 (mkVHDLBasicId lengthId) Nothing) AST.:-:
972 AST.PrimName (AST.NSimple iId) AST.:-:
975 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
977 -----------------------------------------------------------------------------
978 -- A table of builtin functions
979 -----------------------------------------------------------------------------
981 -- | The builtin functions we support. Maps a name to an argument count and a
983 globalNameTable :: NameTable
984 globalNameTable = Map.fromList
985 [ (exId , (2, genFCall False ) )
986 , (replaceId , (3, genFCall False ) )
987 , (headId , (1, genFCall True ) )
988 , (lastId , (1, genFCall True ) )
989 , (tailId , (1, genFCall False ) )
990 , (initId , (1, genFCall False ) )
991 , (takeId , (2, genFCall False ) )
992 , (dropId , (2, genFCall False ) )
993 , (selId , (4, genFCall False ) )
994 , (plusgtId , (2, genFCall False ) )
995 , (ltplusId , (2, genFCall False ) )
996 , (plusplusId , (2, genFCall False ) )
997 , (mapId , (2, genMap ) )
998 , (zipWithId , (3, genZipWith ) )
999 , (foldlId , (3, genFoldl ) )
1000 , (foldrId , (3, genFoldr ) )
1001 , (zipId , (2, genZip ) )
1002 , (unzipId , (1, genUnzip ) )
1003 , (shiftlId , (2, genFCall False ) )
1004 , (shiftrId , (2, genFCall False ) )
1005 , (rotlId , (1, genFCall False ) )
1006 , (rotrId , (1, genFCall False ) )
1007 , (concatId , (1, genConcat ) )
1008 , (reverseId , (1, genFCall False ) )
1009 , (iteratenId , (3, genIteraten ) )
1010 , (iterateId , (2, genIterate ) )
1011 , (generatenId , (3, genGeneraten ) )
1012 , (generateId , (2, genGenerate ) )
1013 , (emptyId , (0, genFCall False ) )
1014 , (singletonId , (1, genFCall False ) )
1015 , (copynId , (2, genFCall False ) )
1016 , (copyId , (1, genCopy ) )
1017 , (lengthTId , (1, genFCall False ) )
1018 , (nullId , (1, genFCall False ) )
1019 , (hwxorId , (2, genOperator2 AST.Xor ) )
1020 , (hwandId , (2, genOperator2 AST.And ) )
1021 , (hworId , (2, genOperator2 AST.Or ) )
1022 , (hwnotId , (1, genOperator1 AST.Not ) )
1023 , (plusId , (2, genOperator2 (AST.:+:) ) )
1024 , (timesId , (2, genOperator2 (AST.:*:) ) )
1025 , (negateId , (1, genNegation ) )
1026 , (minusId , (2, genOperator2 (AST.:-:) ) )
1027 , (fromSizedWordId , (1, genFromSizedWord ) )
1028 , (fromIntegerId , (1, genFromInteger ) )