1 module CLasH.VHDL.Generate where
4 import qualified Data.Map as Map
6 import qualified Data.Either as Either
8 import Data.Accessor.MonadState as MonadState
12 import qualified Language.VHDL.AST as AST
15 import qualified CoreSyn
18 import qualified IdInfo
19 import qualified Literal
21 import qualified TyCon
24 import CLasH.VHDL.Constants
25 import CLasH.VHDL.VHDLTypes
26 import CLasH.VHDL.VHDLTools
27 import CLasH.Utils.Core.CoreTools
28 import CLasH.Utils.Pretty
30 -----------------------------------------------------------------------------
31 -- Functions to generate VHDL for builtin functions
32 -----------------------------------------------------------------------------
34 -- | A function to wrap a builder-like function that expects its arguments to
36 genExprArgs wrap dst func args = do
37 args' <- eitherCoreOrExprArgs args
40 eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
41 eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
43 -- | A function to wrap a builder-like function that expects its arguments to
46 (dst -> func -> [Var.Var] -> res)
47 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
48 genVarArgs wrap dst func args = wrap dst func args'
50 args' = map exprToVar exprargs
51 -- Check (rather crudely) that all arguments are CoreExprs
52 (exprargs, []) = Either.partitionEithers args
54 -- | A function to wrap a builder-like function that expects its arguments to
57 (dst -> func -> [Literal.Literal] -> res)
58 -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
59 genLitArgs wrap dst func args = wrap dst func args'
61 args' = map exprToLit litargs
62 -- FIXME: Check if we were passed an CoreSyn.App
63 litargs = concat (map getLiterals exprargs)
64 (exprargs, []) = Either.partitionEithers args
66 -- | A function to wrap a builder-like function that produces an expression
67 -- and expects it to be assigned to the destination.
69 ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
70 -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
71 genExprRes wrap dst func args = do
72 expr <- wrap dst func args
73 return $ [mkUncondAssign dst expr]
75 -- | Generate a binary operator application. The first argument should be a
76 -- constructor from the AST.Expr type, e.g. AST.And.
77 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
78 genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
79 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
80 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
82 -- | Generate a unary operator application
83 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
84 genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
85 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
86 genOperator1' op _ f [arg] = return $ op arg
88 -- | Generate a unary operator application
89 genNegation :: BuiltinBuilder
90 genNegation = genVarArgs $ genExprRes genNegation'
91 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
92 genNegation' _ f [arg] = do
93 arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
94 let ty = Var.varType arg
95 let (tycon, args) = Type.splitTyConApp ty
96 let name = Name.getOccString (TyCon.tyConName tycon)
98 "SizedInt" -> return $ AST.Neg arg1
99 otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
101 -- | Generate a function call from the destination binder, function name and a
102 -- list of expressions (its arguments)
103 genFCall :: Bool -> BuiltinBuilder
104 genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
105 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
106 genFCall' switch (Left res) f args = do
107 let fname = varToString f
108 let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
109 id <- MonadState.lift vsType $ vectorFunId el_ty fname
110 return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
111 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
112 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
114 genFromSizedWord :: BuiltinBuilder
115 genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
116 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
117 genFromSizedWord' (Left res) f args = do
118 let fname = varToString f
119 return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
120 map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
121 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
123 genResize :: BuiltinBuilder
124 genResize = genExprArgs $ genExprRes genResize'
125 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
126 genResize' (Left res) f [arg] = do {
127 ; let { ty = Var.varType res
128 ; (tycon, args) = Type.splitTyConApp ty
129 ; name = Name.getOccString (TyCon.tyConName tycon)
131 ; len <- case name of
132 "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
133 "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
134 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
135 [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
137 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
139 -- FIXME: I'm calling genLitArgs which is very specific function,
140 -- which needs to be fixed as well
141 genFromInteger :: BuiltinBuilder
142 genFromInteger = genLitArgs $ genExprRes genFromInteger'
143 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
144 genFromInteger' (Left res) f lits = do {
145 ; let { ty = Var.varType res
146 ; (tycon, args) = Type.splitTyConApp ty
147 ; name = Name.getOccString (TyCon.tyConName tycon)
150 "RangedWord" -> return $ AST.PrimLit (show (last lits))
152 ; len <- case name of
153 "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
154 "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
155 "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty)
156 ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
157 ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
158 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
162 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
164 genSizedInt :: BuiltinBuilder
165 genSizedInt = genFromInteger
167 -- | Generate a Builder for the builtin datacon TFVec
168 genTFVec :: BuiltinBuilder
169 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
170 -- Generate Assignments for all the binders
171 ; letAssigns <- mapM genBinderAssign letBinders
172 -- Generate assignments for the result (which might be another let binding)
173 ; (resBinders,resAssignments) <- genResAssign letRes
174 -- Get all the Assigned binders
175 ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
176 -- Make signal names for all the assigned binders
177 ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
178 -- Assign all the signals to the resulting vector
179 ; let { vecsigns = mkAggregateSignal sigs
180 ; vecassign = mkUncondAssign (Left res) vecsigns
182 -- Generate all the signal declaration for the assigned binders
183 ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
184 ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
185 -- Setup the VHDL Block
186 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
187 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
189 -- Return the block statement coressponding to the TFVec literal
190 ; return $ [AST.CSBSm block]
193 genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
194 -- For now we only translate applications
195 genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
196 let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
197 let valargs = get_val_args (Var.varType f) args
198 apps <- genApplication (Left bndr) f (map Left valargs)
199 return (Just bndr, apps)
200 genBinderAssign _ = return (Nothing,[])
201 genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
202 genResAssign app@(CoreSyn.App _ letexpr) = do
204 (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
205 letapps <- mapM genBinderAssign letbndrs
206 let bndrs = Maybe.catMaybes (map fst letapps)
207 let app = (map snd letapps)
208 (vars, apps) <- genResAssign letres
209 return ((bndrs ++ vars),((concat app) ++ apps))
210 otherwise -> return ([],[])
211 genResAssign _ = return ([],[])
213 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
214 ; let { elems = reduceCoreListToHsList app
215 -- Make signal names for all the binders
216 ; binders = map (\expr -> case expr of
218 otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
219 ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
221 ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders
222 -- Assign all the signals to the resulting vector
223 ; let { vecsigns = mkAggregateSignal sigs
224 ; vecassign = mkUncondAssign (Left res) vecsigns
225 -- Setup the VHDL Block
226 ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
227 ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
229 -- Return the block statement coressponding to the TFVec literal
230 ; return $ [AST.CSBSm block]
233 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
235 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
237 -- | Generate a generate statement for the builtin function "map"
238 genMap :: BuiltinBuilder
239 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
240 -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
241 -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
242 -- we must index it (which we couldn't if it was a VHDL Expr, since only
243 -- VHDLNames can be indexed).
244 -- Setup the generate scheme
245 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
246 -- TODO: Use something better than varToString
247 ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
248 ; n_id = mkVHDLBasicId "n"
249 ; n_expr = idToVHDLExpr n_id
250 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
251 ; genScheme = AST.ForGn n_id range
252 -- Create the content of the generate statement: Applying the mapped_f to
253 -- each of the elements in arg, storing to each element in res
254 ; resname = mkIndexedName (varToVHDLName res) n_expr
255 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
256 ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
257 ; valargs = get_val_args (Var.varType real_f) already_mapped_args
259 ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
260 -- Return the generate statement
261 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
264 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
266 genZipWith :: BuiltinBuilder
267 genZipWith = genVarArgs genZipWith'
268 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
269 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
270 -- Setup the generate scheme
271 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
272 -- TODO: Use something better than varToString
273 ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
274 ; n_id = mkVHDLBasicId "n"
275 ; n_expr = idToVHDLExpr n_id
276 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
277 ; genScheme = AST.ForGn n_id range
278 -- Create the content of the generate statement: Applying the zipped_f to
279 -- each of the elements in arg1 and arg2, storing to each element in res
280 ; resname = mkIndexedName (varToVHDLName res) n_expr
281 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
282 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
284 ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
285 -- Return the generate functions
286 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
289 genFoldl :: BuiltinBuilder
290 genFoldl = genFold True
292 genFoldr :: BuiltinBuilder
293 genFoldr = genFold False
295 genFold :: Bool -> BuiltinBuilder
296 genFold left = genVarArgs (genFold' left)
298 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
299 genFold' left res f args@[folded_f , start ,vec]= do
300 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
301 genFold'' len left res f args
303 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
304 -- Special case for an empty input vector, just assign start to res
305 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
306 arg <- MonadState.lift vsType $ varToVHDLExpr start
307 return [mkUncondAssign (Left res) arg]
309 genFold'' len left (Left res) f [folded_f, start, vec] = do
311 --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
312 -- An expression for len-1
313 let len_min_expr = (AST.PrimLit $ show (len-1))
314 -- evec is (TFVec n), so it still needs an element type
315 let (nvec, _) = Type.splitAppTy (Var.varType vec)
316 -- Put the type of the start value in nvec, this will be the type of our
318 let tmp_ty = Type.mkAppTy nvec (Var.varType start)
319 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
320 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
321 -- Setup the generate scheme
322 let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
323 let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
324 let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
325 else AST.DownRange len_min_expr (AST.PrimLit "0")
326 let gen_scheme = AST.ForGn n_id gen_range
327 -- Make the intermediate vector
328 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
329 -- Create the generate statement
330 cells <- sequence [genFirstCell, genOtherCell]
331 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
332 -- Assign tmp[len-1] or tmp[0] to res
333 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
334 (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
335 (mkIndexedName tmp_name (AST.PrimLit "0")))
336 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
337 return [AST.CSBSm block]
339 -- An id for the counter
340 n_id = mkVHDLBasicId "n"
341 n_cur = idToVHDLExpr n_id
342 -- An expression for previous n
343 n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
344 else (n_cur AST.:+: (AST.PrimLit "1"))
345 -- An id for the tmp result vector
346 tmp_id = mkVHDLBasicId "tmp"
347 tmp_name = AST.NSimple tmp_id
348 -- Generate parts of the fold
349 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
351 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
352 let cond_label = mkVHDLExtId "firstcell"
353 -- if n == 0 or n == len-1
354 let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
355 else (AST.PrimLit $ show (len-1)))
356 -- Output to tmp[current n]
357 let resname = mkIndexedName tmp_name n_cur
359 argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
360 -- Input from vec[current n]
361 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
362 app_concsms <- genApplication (Right resname) folded_f ( if left then
363 [Right argexpr1, Right argexpr2]
365 [Right argexpr2, Right argexpr1]
367 -- Return the conditional generate part
368 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
371 len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
372 let cond_label = mkVHDLExtId "othercell"
373 -- if n > 0 or n < len-1
374 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
375 else (AST.PrimLit $ show (len-1)))
376 -- Output to tmp[current n]
377 let resname = mkIndexedName tmp_name n_cur
378 -- Input from tmp[previous n]
379 let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
380 -- Input from vec[current n]
381 let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
382 app_concsms <- genApplication (Right resname) folded_f ( if left then
383 [Right argexpr1, Right argexpr2]
385 [Right argexpr2, Right argexpr1]
387 -- Return the conditional generate part
388 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
390 -- | Generate a generate statement for the builtin function "zip"
391 genZip :: BuiltinBuilder
392 genZip = genVarArgs genZip'
393 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
394 genZip' (Left res) f args@[arg1, arg2] = do {
395 -- Setup the generate scheme
396 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
397 -- TODO: Use something better than varToString
398 ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
399 ; n_id = mkVHDLBasicId "n"
400 ; n_expr = idToVHDLExpr n_id
401 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
402 ; genScheme = AST.ForGn n_id range
403 ; resname' = mkIndexedName (varToVHDLName res) n_expr
404 ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
405 ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
407 ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
408 ; let { resnameA = mkSelectedName resname' (labels!!0)
409 ; resnameB = mkSelectedName resname' (labels!!1)
410 ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
411 ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
413 -- Return the generate functions
414 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
417 -- | Generate a generate statement for the builtin function "unzip"
418 genUnzip :: BuiltinBuilder
419 genUnzip = genVarArgs genUnzip'
420 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
421 genUnzip' (Left res) f args@[arg] = do {
422 -- Setup the generate scheme
423 ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
424 -- TODO: Use something better than varToString
425 ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
426 ; n_id = mkVHDLBasicId "n"
427 ; n_expr = idToVHDLExpr n_id
428 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
429 ; genScheme = AST.ForGn n_id range
430 ; resname' = varToVHDLName res
431 ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
433 ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
434 ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
435 ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
436 ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
437 ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
438 ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
439 ; resA_assign = mkUncondAssign (Right resnameA) argexprA
440 ; resB_assign = mkUncondAssign (Right resnameB) argexprB
442 -- Return the generate functions
443 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
446 genCopy :: BuiltinBuilder
447 genCopy = genVarArgs genCopy'
448 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
449 genCopy' (Left res) f args@[arg] =
451 resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
452 (AST.PrimName $ (varToVHDLName arg))]
453 out_assign = mkUncondAssign (Left res) resExpr
457 genConcat :: BuiltinBuilder
458 genConcat = genVarArgs genConcat'
459 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
460 genConcat' (Left res) f args@[arg] = do {
461 -- Setup the generate scheme
462 ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
463 ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
464 ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
465 -- TODO: Use something better than varToString
466 ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
467 ; n_id = mkVHDLBasicId "n"
468 ; n_expr = idToVHDLExpr n_id
469 ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
470 ; genScheme = AST.ForGn n_id range
471 -- Create the content of the generate statement: Applying the mapped_f to
472 -- each of the elements in arg, storing to each element in res
473 ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
474 ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
475 ; resname = vecSlice fromRange toRange
476 ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
477 ; out_assign = mkUncondAssign (Right resname) argexpr
479 -- Return the generate statement
480 ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
483 vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
484 (AST.ToRange init last))
486 genIteraten :: BuiltinBuilder
487 genIteraten dst f args = genIterate dst f (tail args)
489 genIterate :: BuiltinBuilder
490 genIterate = genIterateOrGenerate True
492 genGeneraten :: BuiltinBuilder
493 genGeneraten dst f args = genGenerate dst f (tail args)
495 genGenerate :: BuiltinBuilder
496 genGenerate = genIterateOrGenerate False
498 genIterateOrGenerate :: Bool -> BuiltinBuilder
499 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
501 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
502 genIterateOrGenerate' iter (Left res) f args = do
503 len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
504 genIterateOrGenerate'' len iter (Left res) f args
506 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
507 -- Special case for an empty input vector, just assign start to res
508 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
510 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
512 -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
513 -- An expression for len-1
514 let len_min_expr = (AST.PrimLit $ show (len-1))
515 -- -- evec is (TFVec n), so it still needs an element type
516 -- let (nvec, _) = splitAppTy (Var.varType vec)
517 -- -- Put the type of the start value in nvec, this will be the type of our
518 -- -- temporary vector
519 let tmp_ty = Var.varType res
520 let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
521 tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
522 -- Setup the generate scheme
523 let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
524 let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
525 let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
526 let gen_scheme = AST.ForGn n_id gen_range
527 -- Make the intermediate vector
528 let tmp_dec = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
529 -- Create the generate statement
530 cells <- sequence [genFirstCell, genOtherCell]
531 let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
532 -- Assign tmp[len-1] or tmp[0] to res
533 let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
534 let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
535 return [AST.CSBSm block]
537 -- An id for the counter
538 n_id = mkVHDLBasicId "n"
539 n_cur = idToVHDLExpr n_id
540 -- An expression for previous n
541 n_prev = n_cur AST.:-: (AST.PrimLit "1")
542 -- An id for the tmp result vector
543 tmp_id = mkVHDLBasicId "tmp"
544 tmp_name = AST.NSimple tmp_id
545 -- Generate parts of the fold
546 genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
548 let cond_label = mkVHDLExtId "firstcell"
549 -- if n == 0 or n == len-1
550 let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
551 -- Output to tmp[current n]
552 let resname = mkIndexedName tmp_name n_cur
554 argexpr <- MonadState.lift vsType $ varToVHDLExpr start
555 let startassign = mkUncondAssign (Right resname) argexpr
556 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
557 -- Return the conditional generate part
558 return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
565 let cond_label = mkVHDLExtId "othercell"
566 -- if n > 0 or n < len-1
567 let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
568 -- Output to tmp[current n]
569 let resname = mkIndexedName tmp_name n_cur
570 -- Input from tmp[previous n]
571 let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
572 app_concsms <- genApplication (Right resname) app_f [Right argexpr]
573 -- Return the conditional generate part
574 return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
577 -----------------------------------------------------------------------------
578 -- Function to generate VHDL for applications
579 -----------------------------------------------------------------------------
581 (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
582 -> CoreSyn.CoreBndr -- ^ The function to apply
583 -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
584 -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
585 genApplication dst f args = do
586 case Var.isGlobalId f of
588 signatures <- getA vsSignatures
589 -- This is a local id, so it should be a function whose definition we
590 -- have and which can be turned into a component instantiation.
591 case (Map.lookup f signatures) of
593 args' <- eitherCoreOrExprArgs args
594 -- We have a signature, this is a top level binding. Generate a
595 -- component instantiation.
596 let entity_id = ent_id signature
597 -- TODO: Using show here isn't really pretty, but we'll need some
598 -- unique-ish value...
599 let label = "comp_ins_" ++ (either show prettyShow) dst
600 let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
601 return [mkComponentInst label entity_id portmaps]
603 -- No signature, so this must be a local variable reference. It
604 -- should have a representable type (and thus, no arguments) and a
605 -- signal should be generated for it. Just generate an
606 -- unconditional assignment here.
607 f' <- MonadState.lift vsType $ varToVHDLExpr f
608 return $ [mkUncondAssign dst f']
610 case Var.idDetails f of
611 IdInfo.DataConWorkId dc -> case dst of
612 -- It's a datacon. Create a record from its arguments.
614 -- We have the bndr, so we can get at the type
615 labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
616 args' <- eitherCoreOrExprArgs args
617 return $ zipWith mkassign labels $ args'
619 mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
621 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
622 mkUncondAssign (Right sel_name) arg
623 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
624 IdInfo.DataConWrapId dc -> case dst of
625 -- It's a datacon. Create a record from its arguments.
627 case (Map.lookup (varToString f) globalNameTable) of
628 Just (arg_count, builder) ->
629 if length args == arg_count then
632 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
633 Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
634 Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
635 IdInfo.VanillaId -> do
636 -- It's a global value imported from elsewhere. These can be builtin
637 -- functions. Look up the function name in the name table and execute
638 -- the associated builder if there is any and the argument count matches
639 -- (this should always be the case if it typechecks, but just to be
641 case (Map.lookup (varToString f) globalNameTable) of
642 Just (arg_count, builder) ->
643 if length args == arg_count then
646 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
647 Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
648 IdInfo.ClassOpId cls -> do
649 -- FIXME: Not looking for what instance this class op is called for
650 -- Is quite stupid of course.
651 case (Map.lookup (varToString f) globalNameTable) of
652 Just (arg_count, builder) ->
653 if length args == arg_count then
656 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
657 Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
658 details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
660 -----------------------------------------------------------------------------
661 -- Functions to generate functions dealing with vectors.
662 -----------------------------------------------------------------------------
664 -- Returns the VHDLId of the vector function with the given name for the given
665 -- element type. Generates -- this function if needed.
666 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
667 vectorFunId el_ty fname = do
668 let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
669 elemTM <- vhdl_ty error_msg el_ty
670 -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
671 -- the VHDLState or something.
672 let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
673 typefuns <- getA vsTypeFuns
674 case Map.lookup (OrdType el_ty, fname) typefuns of
675 -- Function already generated, just return it
676 Just (id, _) -> return id
677 -- Function not generated yet, generate it
679 let functions = genUnconsVectorFuns elemTM vectorTM
680 case lookup fname functions of
682 modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
683 mapM_ (vectorFunId el_ty) (snd body)
685 Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
687 function_id = mkVHDLExtId fname
689 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
690 -> AST.TypeMark -- ^ type of the vector
691 -> [(String, (AST.SubProgBody, [String]))]
692 genUnconsVectorFuns elemTM vectorTM =
693 [ (exId, (AST.SubProgBody exSpec [] [exExpr],[]))
694 , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
695 , (lastId, (AST.SubProgBody lastSpec [] [lastExpr],[]))
696 , (initId, (AST.SubProgBody initSpec [AST.SPVD initVar] [initExpr, initRet],[]))
697 , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
698 , (takeId, (AST.SubProgBody takeSpec [AST.SPVD takeVar] [takeExpr, takeRet],[minimumId]))
699 , (dropId, (AST.SubProgBody dropSpec [AST.SPVD dropVar] [dropExpr, dropRet],[]))
700 , (plusgtId, (AST.SubProgBody plusgtSpec [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
701 , (emptyId, (AST.SubProgBody emptySpec [AST.SPCD emptyVar] [emptyExpr],[]))
702 , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
703 , (copynId, (AST.SubProgBody copynSpec [AST.SPVD copynVar] [copynExpr],[]))
704 , (selId, (AST.SubProgBody selSpec [AST.SPVD selVar] [selFor, selRet],[]))
705 , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
706 , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
707 , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
708 , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
709 , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
710 , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
711 , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
712 , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
713 , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
716 ixPar = AST.unsafeVHDLBasicId "ix"
717 vecPar = AST.unsafeVHDLBasicId "vec"
718 vec1Par = AST.unsafeVHDLBasicId "vec1"
719 vec2Par = AST.unsafeVHDLBasicId "vec2"
720 nPar = AST.unsafeVHDLBasicId "n"
721 leftPar = AST.unsafeVHDLBasicId "nLeft"
722 rightPar = AST.unsafeVHDLBasicId "nRight"
723 iId = AST.unsafeVHDLBasicId "i"
725 aPar = AST.unsafeVHDLBasicId "a"
726 fPar = AST.unsafeVHDLBasicId "f"
727 sPar = AST.unsafeVHDLBasicId "s"
728 resId = AST.unsafeVHDLBasicId "res"
729 exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
730 AST.IfaceVarDec ixPar naturalTM] elemTM
731 exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
732 (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
734 replaceSpec = AST.Function (mkVHDLExtId replaceId) [ AST.IfaceVarDec vecPar vectorTM
735 , AST.IfaceVarDec iPar naturalTM
736 , AST.IfaceVarDec aPar elemTM
738 -- variable res : fsvec_x (0 to vec'length-1);
741 (AST.SubtypeIn vectorTM
742 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
743 [AST.ToRange (AST.PrimLit "0")
744 (AST.PrimName (AST.NAttribute $
745 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
746 (AST.PrimLit "1")) ]))
748 -- res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
749 replaceExpr = AST.NSimple resId AST.:=
750 (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
751 AST.PrimName (AST.NSimple aPar) AST.:&:
752 vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
753 ((AST.PrimName (AST.NAttribute $
754 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
755 AST.:-: AST.PrimLit "1"))
756 replaceRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
757 vecSlice init last = AST.PrimName (AST.NSlice
760 (AST.ToRange init last)))
761 lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
762 -- return vec(vec'length-1);
763 lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
765 [AST.PrimName (AST.NAttribute $
766 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
767 AST.:-: AST.PrimLit "1"])))
768 initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
769 -- variable res : fsvec_x (0 to vec'length-2);
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) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
777 (AST.PrimLit "2")) ]))
779 -- resAST.:= vec(0 to vec'length-2)
780 initExpr = AST.NSimple resId AST.:= (vecSlice
782 (AST.PrimName (AST.NAttribute $
783 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
784 AST.:-: AST.PrimLit "2"))
785 initRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
786 minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar naturalTM,
787 AST.IfaceVarDec rightPar naturalTM ] naturalTM
788 minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
789 [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
791 (Just $ AST.Else [minimumExprRet])
792 where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
793 takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar naturalTM,
794 AST.IfaceVarDec vecPar vectorTM ] vectorTM
795 -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
796 minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
797 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
798 ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
799 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
802 (AST.SubtypeIn vectorTM
803 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
804 [AST.ToRange (AST.PrimLit "0")
806 (AST.PrimLit "1")) ]))
808 -- res AST.:= vec(0 to n-1)
809 takeExpr = AST.NSimple resId AST.:=
810 (vecSlice (AST.PrimLit "0")
811 (minLength AST.:-: AST.PrimLit "1"))
812 takeRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
813 dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar naturalTM,
814 AST.IfaceVarDec vecPar vectorTM ] vectorTM
815 -- variable res : fsvec_x (0 to vec'length-n-1);
818 (AST.SubtypeIn vectorTM
819 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
820 [AST.ToRange (AST.PrimLit "0")
821 (AST.PrimName (AST.NAttribute $
822 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
823 (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
825 -- res AST.:= vec(n to vec'length-1)
826 dropExpr = AST.NSimple resId AST.:= (vecSlice
827 (AST.PrimName $ AST.NSimple nPar)
828 (AST.PrimName (AST.NAttribute $
829 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
830 AST.:-: AST.PrimLit "1"))
831 dropRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
832 plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar elemTM,
833 AST.IfaceVarDec vecPar vectorTM] vectorTM
834 -- variable res : fsvec_x (0 to vec'length);
837 (AST.SubtypeIn vectorTM
838 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
839 [AST.ToRange (AST.PrimLit "0")
840 (AST.PrimName (AST.NAttribute $
841 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
843 plusgtExpr = AST.NSimple resId AST.:=
844 ((AST.PrimName $ AST.NSimple aPar) AST.:&:
845 (AST.PrimName $ AST.NSimple vecPar))
846 plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
847 emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
850 (AST.SubtypeIn vectorTM Nothing)
851 (Just $ AST.PrimLit "\"\"")
852 emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
853 singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
855 -- variable res : fsvec_x (0 to 0) := (others => a);
858 (AST.SubtypeIn vectorTM
859 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
860 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
861 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
862 (AST.PrimName $ AST.NSimple aPar)])
863 singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
864 copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar naturalTM,
865 AST.IfaceVarDec aPar elemTM ] vectorTM
866 -- variable res : fsvec_x (0 to n-1) := (others => a);
869 (AST.SubtypeIn vectorTM
870 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
871 [AST.ToRange (AST.PrimLit "0")
872 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
873 (AST.PrimLit "1")) ]))
874 (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
875 (AST.PrimName $ AST.NSimple aPar)])
877 copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
878 selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar naturalTM,
879 AST.IfaceVarDec sPar naturalTM,
880 AST.IfaceVarDec nPar naturalTM,
881 AST.IfaceVarDec vecPar vectorTM ] vectorTM
882 -- variable res : fsvec_x (0 to n-1);
885 (AST.SubtypeIn vectorTM
886 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
887 [AST.ToRange (AST.PrimLit "0")
888 ((AST.PrimName (AST.NSimple nPar)) AST.:-:
889 (AST.PrimLit "1")) ])
892 -- for i res'range loop
893 -- res(i) := vec(f+i*s);
895 selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
896 -- res(i) := vec(f+i*s);
897 selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
898 (AST.PrimName (AST.NSimple iId) AST.:*:
899 AST.PrimName (AST.NSimple sPar)) in
900 AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
901 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
903 selRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
904 ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
905 AST.IfaceVarDec aPar elemTM] vectorTM
906 -- variable res : fsvec_x (0 to vec'length);
909 (AST.SubtypeIn vectorTM
910 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
911 [AST.ToRange (AST.PrimLit "0")
912 (AST.PrimName (AST.NAttribute $
913 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
915 ltplusExpr = AST.NSimple resId AST.:=
916 ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
917 (AST.PrimName $ AST.NSimple aPar))
918 ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
919 plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
920 AST.IfaceVarDec vec2Par vectorTM]
922 -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
925 (AST.SubtypeIn vectorTM
926 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
927 [AST.ToRange (AST.PrimLit "0")
928 (AST.PrimName (AST.NAttribute $
929 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
930 AST.PrimName (AST.NAttribute $
931 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
934 plusplusExpr = AST.NSimple resId AST.:=
935 ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
936 (AST.PrimName $ AST.NSimple vec2Par))
937 plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
938 lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
939 lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
940 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
941 shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
942 AST.IfaceVarDec aPar elemTM ] vectorTM
943 -- variable res : fsvec_x (0 to vec'length-1);
946 (AST.SubtypeIn vectorTM
947 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
948 [AST.ToRange (AST.PrimLit "0")
949 (AST.PrimName (AST.NAttribute $
950 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
951 (AST.PrimLit "1")) ]))
953 -- res := a & init(vec)
954 shiftlExpr = AST.NSimple resId AST.:=
955 (AST.PrimName (AST.NSimple aPar) AST.:&:
956 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
957 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
958 shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
959 shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
960 AST.IfaceVarDec aPar elemTM ] vectorTM
961 -- variable res : fsvec_x (0 to vec'length-1);
964 (AST.SubtypeIn vectorTM
965 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
966 [AST.ToRange (AST.PrimLit "0")
967 (AST.PrimName (AST.NAttribute $
968 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
969 (AST.PrimLit "1")) ]))
971 -- res := tail(vec) & a
972 shiftrExpr = AST.NSimple resId AST.:=
973 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
974 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
975 (AST.PrimName (AST.NSimple aPar)))
977 shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
978 nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
979 -- return vec'length = 0
980 nullExpr = AST.ReturnSm (Just $
981 AST.PrimName (AST.NAttribute $
982 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
984 rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
985 -- variable res : fsvec_x (0 to vec'length-1);
988 (AST.SubtypeIn vectorTM
989 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
990 [AST.ToRange (AST.PrimLit "0")
991 (AST.PrimName (AST.NAttribute $
992 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
993 (AST.PrimLit "1")) ]))
995 -- if null(vec) then res := vec else res := last(vec) & init(vec)
996 rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
997 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
998 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1000 (Just $ AST.Else [rotlExprRet])
1002 AST.NSimple resId AST.:=
1003 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1004 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1005 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1006 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1007 rotlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1008 rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1009 -- variable res : fsvec_x (0 to vec'length-1);
1012 (AST.SubtypeIn vectorTM
1013 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1014 [AST.ToRange (AST.PrimLit "0")
1015 (AST.PrimName (AST.NAttribute $
1016 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1017 (AST.PrimLit "1")) ]))
1019 -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1020 rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1021 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1022 [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1024 (Just $ AST.Else [rotrExprRet])
1026 AST.NSimple resId AST.:=
1027 ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1028 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1029 (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1030 [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1031 rotrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1032 reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1035 (AST.SubtypeIn vectorTM
1036 (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1037 [AST.ToRange (AST.PrimLit "0")
1038 (AST.PrimName (AST.NAttribute $
1039 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1040 (AST.PrimLit "1")) ]))
1042 -- for i in 0 to res'range loop
1043 -- res(vec'length-i-1) := vec(i);
1046 AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1047 -- res(vec'length-i-1) := vec(i);
1048 reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1049 (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1050 [AST.PrimName $ AST.NSimple iId]))
1051 where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1052 (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1053 AST.PrimName (AST.NSimple iId) AST.:-:
1056 reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1059 -----------------------------------------------------------------------------
1060 -- A table of builtin functions
1061 -----------------------------------------------------------------------------
1063 -- | The builtin functions we support. Maps a name to an argument count and a
1064 -- builder function.
1065 globalNameTable :: NameTable
1066 globalNameTable = Map.fromList
1067 [ (exId , (2, genFCall True ) )
1068 , (replaceId , (3, genFCall False ) )
1069 , (headId , (1, genFCall True ) )
1070 , (lastId , (1, genFCall True ) )
1071 , (tailId , (1, genFCall False ) )
1072 , (initId , (1, genFCall False ) )
1073 , (takeId , (2, genFCall False ) )
1074 , (dropId , (2, genFCall False ) )
1075 , (selId , (4, genFCall False ) )
1076 , (plusgtId , (2, genFCall False ) )
1077 , (ltplusId , (2, genFCall False ) )
1078 , (plusplusId , (2, genFCall False ) )
1079 , (mapId , (2, genMap ) )
1080 , (zipWithId , (3, genZipWith ) )
1081 , (foldlId , (3, genFoldl ) )
1082 , (foldrId , (3, genFoldr ) )
1083 , (zipId , (2, genZip ) )
1084 , (unzipId , (1, genUnzip ) )
1085 , (shiftlId , (2, genFCall False ) )
1086 , (shiftrId , (2, genFCall False ) )
1087 , (rotlId , (1, genFCall False ) )
1088 , (rotrId , (1, genFCall False ) )
1089 , (concatId , (1, genConcat ) )
1090 , (reverseId , (1, genFCall False ) )
1091 , (iteratenId , (3, genIteraten ) )
1092 , (iterateId , (2, genIterate ) )
1093 , (generatenId , (3, genGeneraten ) )
1094 , (generateId , (2, genGenerate ) )
1095 , (emptyId , (0, genFCall False ) )
1096 , (singletonId , (1, genFCall False ) )
1097 , (copynId , (2, genFCall False ) )
1098 , (copyId , (1, genCopy ) )
1099 , (lengthTId , (1, genFCall False ) )
1100 , (nullId , (1, genFCall False ) )
1101 , (hwxorId , (2, genOperator2 AST.Xor ) )
1102 , (hwandId , (2, genOperator2 AST.And ) )
1103 , (hworId , (2, genOperator2 AST.Or ) )
1104 , (hwnotId , (1, genOperator1 AST.Not ) )
1105 , (plusId , (2, genOperator2 (AST.:+:) ) )
1106 , (timesId , (2, genOperator2 (AST.:*:) ) )
1107 , (negateId , (1, genNegation ) )
1108 , (minusId , (2, genOperator2 (AST.:-:) ) )
1109 , (fromSizedWordId , (1, genFromSizedWord ) )
1110 , (fromIntegerId , (1, genFromInteger ) )
1111 , (resizeId , (1, genResize ) )
1112 , (sizedIntId , (1, genSizedInt ) )
1113 , (tfvecId , (1, genTFVec ) )
1114 , (minimumId , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))