aca4e9570ff0e23dceaf7e7c1c1bf38b9200544e
[matthijs/master-project/cλash.git] / Generate.hs
1 module CLasH.VHDL.Generate where
2
3 -- Standard modules
4 import qualified Data.List as List
5 import qualified Data.Map as Map
6 import qualified Control.Monad as Monad
7 import qualified Maybe
8 import qualified Data.Either as Either
9 import Data.Accessor
10 import Data.Accessor.MonadState as MonadState
11 import Debug.Trace
12
13 -- ForSyDe
14 import qualified Language.VHDL.AST as AST
15
16 -- GHC API
17 import qualified CoreSyn
18 import qualified Type
19 import qualified Var
20 import qualified Id
21 import qualified IdInfo
22 import qualified Literal
23 import qualified Name
24 import qualified TyCon
25
26 -- Local imports
27 import CLasH.Translator.TranslatorTypes
28 import CLasH.VHDL.Constants
29 import CLasH.VHDL.VHDLTypes
30 import CLasH.VHDL.VHDLTools
31 import qualified CLasH.Utils as Utils
32 import CLasH.Utils.Core.CoreTools
33 import CLasH.Utils.Pretty
34 import qualified CLasH.Normalize as Normalize
35
36 -----------------------------------------------------------------------------
37 -- Functions to generate VHDL for user-defined functions.
38 -----------------------------------------------------------------------------
39
40 -- | Create an entity for a given function
41 getEntity ::
42   CoreSyn.CoreBndr
43   -> TranslatorSession Entity -- ^ The resulting entity
44
45 getEntity fname = Utils.makeCached fname tsEntities $ do
46       expr <- Normalize.getNormalized fname
47       -- Strip off lambda's, these will be arguments
48       let (args, letexpr) = CoreSyn.collectBinders expr
49       args' <- mapM mkMap args
50       -- There must be a let at top level 
51       let (CoreSyn.Let binds (CoreSyn.Var res)) = letexpr
52       res' <- mkMap res
53       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
54       let ent_decl = createEntityAST vhdl_id args' res'
55       let signature = Entity vhdl_id args' res' ent_decl
56       return signature
57   where
58     mkMap ::
59       --[(SignalId, SignalInfo)] 
60       CoreSyn.CoreBndr 
61       -> TranslatorSession Port
62     mkMap = (\bndr ->
63       let
64         --info = Maybe.fromMaybe
65         --  (error $ "Signal not found in the name map? This should not happen!")
66         --  (lookup id sigmap)
67         --  Assume the bndr has a valid VHDL id already
68         id = varToVHDLId bndr
69         ty = Var.varType bndr
70         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
71       in do
72         type_mark <- MonadState.lift tsType $ vhdl_ty error_msg ty
73         return (id, type_mark)
74      )
75
76 -- | Create the VHDL AST for an entity
77 createEntityAST ::
78   AST.VHDLId                   -- ^ The name of the function
79   -> [Port]                    -- ^ The entity's arguments
80   -> Port                      -- ^ The entity's result
81   -> AST.EntityDec             -- ^ The entity with the ent_decl filled in as well
82
83 createEntityAST vhdl_id args res =
84   AST.EntityDec vhdl_id ports
85   where
86     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
87     ports = map (mkIfaceSigDec AST.In) args
88               ++ [mkIfaceSigDec AST.Out res]
89               ++ [clk_port]
90     -- Add a clk port if we have state
91     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
92
93 -- | Create a port declaration
94 mkIfaceSigDec ::
95   AST.Mode                         -- ^ The mode for the port (In / Out)
96   -> (AST.VHDLId, AST.TypeMark)    -- ^ The id and type for the port
97   -> AST.IfaceSigDec               -- ^ The resulting port declaration
98
99 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
100
101 -- | Create an architecture for a given function
102 getArchitecture ::
103   CoreSyn.CoreBndr -- ^ The function to get an architecture for
104   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
105   -- ^ The architecture for this function
106
107 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
108   expr <- Normalize.getNormalized fname
109   signature <- getEntity fname
110   let entity_id = ent_id signature
111   -- Strip off lambda's, these will be arguments
112   let (args, letexpr) = CoreSyn.collectBinders expr
113   -- There must be a let at top level 
114   let (CoreSyn.Let (CoreSyn.Rec binds) (CoreSyn.Var res)) = letexpr
115
116   -- Create signal declarations for all binders in the let expression, except
117   -- for the output port (that will already have an output port declared in
118   -- the entity).
119   sig_dec_maybes <- mapM (mkSigDec' . fst) (filter ((/=res).fst) binds)
120   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
121
122   (statementss, used_entitiess) <- Monad.mapAndUnzipM mkConcSm binds
123   let statements = concat statementss
124   let used_entities = concat used_entitiess
125   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) (statements ++ procs')
126   return (arch, used_entities)
127   where
128     procs = [] --map mkStateProcSm [] -- (makeStatePairs flatfunc)
129     procs' = map AST.CSPSm procs
130     -- mkSigDec only uses tsTypes from the state
131     mkSigDec' = mkSigDec
132
133 -- | Transforms a core binding into a VHDL concurrent statement
134 mkConcSm ::
135   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
136   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
137   -- ^ The corresponding VHDL concurrent statements and entities
138   --   instantiated.
139
140
141 -- Ignore Cast expressions, they should not longer have any meaning as long as
142 -- the type works out.
143 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
144
145 -- Simple a = b assignments are just like applications, but without arguments.
146 -- We can't just generate an unconditional assignment here, since b might be a
147 -- top level binding (e.g., a function with no arguments).
148 mkConcSm (bndr, CoreSyn.Var v) = do
149   genApplication (Left bndr) v []
150
151 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
152   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
153   let valargs = get_val_args (Var.varType f) args
154   genApplication (Left bndr) f (map Left valargs)
155
156 -- A single alt case must be a selector. This means thee scrutinee is a simple
157 -- variable, the alternative is a dataalt with a single non-wild binder that
158 -- is also returned.
159 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) =
160   case alt of
161     (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
162       case List.elemIndex sel_bndr bndrs of
163         Just i -> do
164           labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
165           let label = labels!!i
166           let sel_name = mkSelectedName (varToVHDLName scrut) label
167           let sel_expr = AST.PrimName sel_name
168           return ([mkUncondAssign (Left bndr) sel_expr], [])
169         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
170       
171     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
172
173 -- Multiple case alt are be conditional assignments and have only wild
174 -- binders in the alts and only variables in the case values and a variable
175 -- for a scrutinee. We check the constructor of the second alt, since the
176 -- first is the default case, if there is any.
177 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
178   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
179   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
180   true_expr <- MonadState.lift tsType $ varToVHDLExpr true
181   false_expr <- MonadState.lift tsType $ varToVHDLExpr false
182   return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
183
184 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
185 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
186 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
187
188 -----------------------------------------------------------------------------
189 -- Functions to generate VHDL for builtin functions
190 -----------------------------------------------------------------------------
191
192 -- | A function to wrap a builder-like function that expects its arguments to
193 -- be expressions.
194 genExprArgs wrap dst func args = do
195   args' <- eitherCoreOrExprArgs args
196   wrap dst func args'
197
198 eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
199 eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift tsType) . varToVHDLExpr . exprToVar) return) args
200
201 -- A function to wrap a builder-like function that generates no component
202 -- instantiations
203 genNoInsts ::
204   (dst -> func -> args -> TranslatorSession [AST.ConcSm])
205   -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
206 genNoInsts wrap dst func args = do
207   concsms <- wrap dst func args
208   return (concsms, [])
209
210 -- | A function to wrap a builder-like function that expects its arguments to
211 -- be variables.
212 genVarArgs ::
213   (dst -> func -> [Var.Var] -> res)
214   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
215 genVarArgs wrap dst func args = wrap dst func args'
216   where
217     args' = map exprToVar exprargs
218     -- Check (rather crudely) that all arguments are CoreExprs
219     (exprargs, []) = Either.partitionEithers args
220
221 -- | A function to wrap a builder-like function that expects its arguments to
222 -- be Literals
223 genLitArgs ::
224   (dst -> func -> [Literal.Literal] -> res)
225   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
226 genLitArgs wrap dst func args = wrap dst func args'
227   where
228     args' = map exprToLit litargs
229     -- FIXME: Check if we were passed an CoreSyn.App
230     litargs = concat (map getLiterals exprargs)
231     (exprargs, []) = Either.partitionEithers args
232
233 -- | A function to wrap a builder-like function that produces an expression
234 -- and expects it to be assigned to the destination.
235 genExprRes ::
236   ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
237   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
238 genExprRes wrap dst func args = do
239   expr <- wrap dst func args
240   return $ [mkUncondAssign dst expr]
241
242 -- | Generate a binary operator application. The first argument should be a
243 -- constructor from the AST.Expr type, e.g. AST.And.
244 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
245 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
246 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
247 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
248
249 -- | Generate a unary operator application
250 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder 
251 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
252 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
253 genOperator1' op _ f [arg] = return $ op arg
254
255 -- | Generate a unary operator application
256 genNegation :: BuiltinBuilder 
257 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
258 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
259 genNegation' _ f [arg] = do
260   arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
261   let ty = Var.varType arg
262   let (tycon, args) = Type.splitTyConApp ty
263   let name = Name.getOccString (TyCon.tyConName tycon)
264   case name of
265     "SizedInt" -> return $ AST.Neg arg1
266     otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name 
267
268 -- | Generate a function call from the destination binder, function name and a
269 -- list of expressions (its arguments)
270 genFCall :: Bool -> BuiltinBuilder 
271 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
272 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
273 genFCall' switch (Left res) f args = do
274   let fname = varToString f
275   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
276   id <- MonadState.lift tsType $ vectorFunId el_ty fname
277   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
278              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
279 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
280
281 genFromSizedWord :: BuiltinBuilder
282 genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
283 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
284 genFromSizedWord' (Left res) f args = do
285   let fname = varToString f
286   return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
287              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
288 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
289
290 genResize :: BuiltinBuilder
291 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
292 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
293 genResize' (Left res) f [arg] = do {
294   ; let { ty = Var.varType res
295         ; (tycon, args) = Type.splitTyConApp ty
296         ; name = Name.getOccString (TyCon.tyConName tycon)
297         } ;
298   ; len <- case name of
299       "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
300       "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
301   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
302              [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
303   }
304 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
305
306 -- FIXME: I'm calling genLitArgs which is very specific function,
307 -- which needs to be fixed as well
308 genFromInteger :: BuiltinBuilder
309 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
310 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
311 genFromInteger' (Left res) f lits = do {
312   ; let { ty = Var.varType res
313         ; (tycon, args) = Type.splitTyConApp ty
314         ; name = Name.getOccString (TyCon.tyConName tycon)
315         } ;
316   ; len <- case name of
317     "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
318     "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
319   ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
320   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname)) 
321             [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
322   }
323
324 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
325
326 genSizedInt :: BuiltinBuilder
327 genSizedInt = genFromInteger
328
329 {-
330 -- | Generate a Builder for the builtin datacon TFVec
331 genTFVec :: BuiltinBuilder
332 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
333   -- Generate Assignments for all the binders
334   ; letAssigns <- mapM genBinderAssign letBinders
335   -- Generate assignments for the result (which might be another let binding)
336   ; (resBinders,resAssignments) <- genResAssign letRes
337   -- Get all the Assigned binders
338   ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
339   -- Make signal names for all the assigned binders
340   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
341   -- Assign all the signals to the resulting vector
342   ; let { vecsigns = mkAggregateSignal sigs
343         ; vecassign = mkUncondAssign (Left res) vecsigns
344         } ;
345   -- Generate all the signal declaration for the assigned binders
346   ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
347   ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
348   -- Setup the VHDL Block
349         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
350         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
351         } ;
352   -- Return the block statement coressponding to the TFVec literal
353   ; return $ [AST.CSBSm block]
354   }
355   where
356     genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
357     -- For now we only translate applications
358     genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
359       let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
360       let valargs = get_val_args (Var.varType f) args
361       apps <- genApplication (Left bndr) f (map Left valargs)
362       return (Just bndr, apps)
363     genBinderAssign _ = return (Nothing,[])
364     genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
365     genResAssign app@(CoreSyn.App _ letexpr) = do
366       case letexpr of
367         (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
368           letapps <- mapM genBinderAssign letbndrs
369           let bndrs = Maybe.catMaybes (map fst letapps)
370           let app = (map snd letapps)
371           (vars, apps) <- genResAssign letres
372           return ((bndrs ++ vars),((concat app) ++ apps))
373         otherwise -> return ([],[])
374     genResAssign _ = return ([],[])
375
376 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
377   ; let { elems = reduceCoreListToHsList app
378   -- Make signal names for all the binders
379         ; binders = map (\expr -> case expr of 
380                           (CoreSyn.Var b) -> b
381                           otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: " 
382                             ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
383         } ;
384   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
385   -- Assign all the signals to the resulting vector
386   ; let { vecsigns = mkAggregateSignal sigs
387         ; vecassign = mkUncondAssign (Left res) vecsigns
388   -- Setup the VHDL Block
389         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
390         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
391         } ;
392   -- Return the block statement coressponding to the TFVec literal
393   ; return $ [AST.CSBSm block]
394   }
395   
396 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
397
398 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
399 -}
400 -- | Generate a generate statement for the builtin function "map"
401 genMap :: BuiltinBuilder
402 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
403   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
404   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
405   -- we must index it (which we couldn't if it was a VHDL Expr, since only
406   -- VHDLNames can be indexed).
407   -- Setup the generate scheme
408   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
409           -- TODO: Use something better than varToString
410   ; let { label       = mkVHDLExtId ("mapVector" ++ (varToString res))
411         ; n_id        = mkVHDLBasicId "n"
412         ; n_expr      = idToVHDLExpr n_id
413         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
414         ; genScheme   = AST.ForGn n_id range
415           -- Create the content of the generate statement: Applying the mapped_f to
416           -- each of the elements in arg, storing to each element in res
417         ; resname     = mkIndexedName (varToVHDLName res) n_expr
418         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
419         ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
420         ; valargs = get_val_args (Var.varType real_f) already_mapped_args
421         } ;
422   ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
423     -- Return the generate statement
424   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
425   }
426
427 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
428     
429 genZipWith :: BuiltinBuilder
430 genZipWith = genVarArgs genZipWith'
431 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
432 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
433   -- Setup the generate scheme
434   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
435           -- TODO: Use something better than varToString
436   ; let { label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
437         ; n_id        = mkVHDLBasicId "n"
438         ; n_expr      = idToVHDLExpr n_id
439         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
440         ; genScheme   = AST.ForGn n_id range
441           -- Create the content of the generate statement: Applying the zipped_f to
442           -- each of the elements in arg1 and arg2, storing to each element in res
443         ; resname     = mkIndexedName (varToVHDLName res) n_expr
444         ; argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
445         ; argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
446         } ;
447   ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
448     -- Return the generate functions
449   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
450   }
451
452 genFoldl :: BuiltinBuilder
453 genFoldl = genFold True
454
455 genFoldr :: BuiltinBuilder
456 genFoldr = genFold False
457
458 genFold :: Bool -> BuiltinBuilder
459 genFold left = genVarArgs (genFold' left)
460
461 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
462 genFold' left res f args@[folded_f , start ,vec]= do
463   len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
464   genFold'' len left res f args
465
466 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
467 -- Special case for an empty input vector, just assign start to res
468 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
469   arg <- MonadState.lift tsType $ varToVHDLExpr start
470   return ([mkUncondAssign (Left res) arg], [])
471     
472 genFold'' len left (Left res) f [folded_f, start, vec] = do
473   -- The vector length
474   --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
475   -- An expression for len-1
476   let len_min_expr = (AST.PrimLit $ show (len-1))
477   -- evec is (TFVec n), so it still needs an element type
478   let (nvec, _) = Type.splitAppTy (Var.varType vec)
479   -- Put the type of the start value in nvec, this will be the type of our
480   -- temporary vector
481   let tmp_ty = Type.mkAppTy nvec (Var.varType start)
482   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
483   tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
484   -- Setup the generate scheme
485   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
486   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
487   let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
488                   else AST.DownRange len_min_expr (AST.PrimLit "0")
489   let gen_scheme   = AST.ForGn n_id gen_range
490   -- Make the intermediate vector
491   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
492   -- Create the generate statement
493   cells' <- sequence [genFirstCell, genOtherCell]
494   let (cells, useds) = unzip cells'
495   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
496   -- Assign tmp[len-1] or tmp[0] to res
497   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
498                     (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
499                     (mkIndexedName tmp_name (AST.PrimLit "0")))      
500   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
501   return ([AST.CSBSm block], concat useds)
502   where
503     -- An id for the counter
504     n_id = mkVHDLBasicId "n"
505     n_cur = idToVHDLExpr n_id
506     -- An expression for previous n
507     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
508                      else (n_cur AST.:+: (AST.PrimLit "1"))
509     -- An id for the tmp result vector
510     tmp_id = mkVHDLBasicId "tmp"
511     tmp_name = AST.NSimple tmp_id
512     -- Generate parts of the fold
513     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
514     genFirstCell = do
515       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
516       let cond_label = mkVHDLExtId "firstcell"
517       -- if n == 0 or n == len-1
518       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
519                                                   else (AST.PrimLit $ show (len-1)))
520       -- Output to tmp[current n]
521       let resname = mkIndexedName tmp_name n_cur
522       -- Input from start
523       argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
524       -- Input from vec[current n]
525       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
526       (app_concsms, used) <- genApplication (Right resname) folded_f  ( if left then
527                                                                   [Right argexpr1, Right argexpr2]
528                                                                 else
529                                                                   [Right argexpr2, Right argexpr1]
530                                                               )
531       -- Return the conditional generate part
532       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
533
534     genOtherCell = do
535       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
536       let cond_label = mkVHDLExtId "othercell"
537       -- if n > 0 or n < len-1
538       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
539                                                    else (AST.PrimLit $ show (len-1)))
540       -- Output to tmp[current n]
541       let resname = mkIndexedName tmp_name n_cur
542       -- Input from tmp[previous n]
543       let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
544       -- Input from vec[current n]
545       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
546       (app_concsms, used) <- genApplication (Right resname) folded_f  ( if left then
547                                                                   [Right argexpr1, Right argexpr2]
548                                                                 else
549                                                                   [Right argexpr2, Right argexpr1]
550                                                               )
551       -- Return the conditional generate part
552       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
553
554 -- | Generate a generate statement for the builtin function "zip"
555 genZip :: BuiltinBuilder
556 genZip = genNoInsts $ genVarArgs genZip'
557 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
558 genZip' (Left res) f args@[arg1, arg2] = do {
559     -- Setup the generate scheme
560   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
561           -- TODO: Use something better than varToString
562   ; let { label           = mkVHDLExtId ("zipVector" ++ (varToString res))
563         ; n_id            = mkVHDLBasicId "n"
564         ; n_expr          = idToVHDLExpr n_id
565         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
566         ; genScheme       = AST.ForGn n_id range
567         ; resname'        = mkIndexedName (varToVHDLName res) n_expr
568         ; argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
569         ; argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
570         } ; 
571   ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
572   ; let { resnameA    = mkSelectedName resname' (labels!!0)
573         ; resnameB    = mkSelectedName resname' (labels!!1)
574         ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
575         ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
576         } ;
577     -- Return the generate functions
578   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
579   }
580     
581 -- | Generate a generate statement for the builtin function "unzip"
582 genUnzip :: BuiltinBuilder
583 genUnzip = genNoInsts $ genVarArgs genUnzip'
584 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
585 genUnzip' (Left res) f args@[arg] = do {
586     -- Setup the generate scheme
587   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
588     -- TODO: Use something better than varToString
589   ; let { label           = mkVHDLExtId ("unzipVector" ++ (varToString res))
590         ; n_id            = mkVHDLBasicId "n"
591         ; n_expr          = idToVHDLExpr n_id
592         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
593         ; genScheme       = AST.ForGn n_id range
594         ; resname'        = varToVHDLName res
595         ; argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
596         } ;
597   ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
598   ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
599   ; let { resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
600         ; resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
601         ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
602         ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
603         ; resA_assign = mkUncondAssign (Right resnameA) argexprA
604         ; resB_assign = mkUncondAssign (Right resnameB) argexprB
605         } ;
606     -- Return the generate functions
607   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
608   }
609
610 genCopy :: BuiltinBuilder 
611 genCopy = genNoInsts $ genVarArgs genCopy'
612 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
613 genCopy' (Left res) f args@[arg] =
614   let
615     resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
616                 (AST.PrimName $ (varToVHDLName arg))]
617     out_assign = mkUncondAssign (Left res) resExpr
618   in 
619     return [out_assign]
620     
621 genConcat :: BuiltinBuilder
622 genConcat = genNoInsts $ genVarArgs genConcat'
623 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
624 genConcat' (Left res) f args@[arg] = do {
625     -- Setup the generate scheme
626   ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
627   ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
628   ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
629           -- TODO: Use something better than varToString
630   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))
631         ; n_id        = mkVHDLBasicId "n"
632         ; n_expr      = idToVHDLExpr n_id
633         ; fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
634         ; genScheme   = AST.ForGn n_id range
635           -- Create the content of the generate statement: Applying the mapped_f to
636           -- each of the elements in arg, storing to each element in res
637         ; toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
638         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
639         ; resname     = vecSlice fromRange toRange
640         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
641         ; out_assign  = mkUncondAssign (Right resname) argexpr
642         } ;
643     -- Return the generate statement
644   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
645   }
646   where
647     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
648                             (AST.ToRange init last))
649
650 genIteraten :: BuiltinBuilder
651 genIteraten dst f args = genIterate dst f (tail args)
652
653 genIterate :: BuiltinBuilder
654 genIterate = genIterateOrGenerate True
655
656 genGeneraten :: BuiltinBuilder
657 genGeneraten dst f args = genGenerate dst f (tail args)
658
659 genGenerate :: BuiltinBuilder
660 genGenerate = genIterateOrGenerate False
661
662 genIterateOrGenerate :: Bool -> BuiltinBuilder
663 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
664
665 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
666 genIterateOrGenerate' iter (Left res) f args = do
667   len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
668   genIterateOrGenerate'' len iter (Left res) f args
669
670 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
671 -- Special case for an empty input vector, just assign start to res
672 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
673
674 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
675   -- The vector length
676   -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
677   -- An expression for len-1
678   let len_min_expr = (AST.PrimLit $ show (len-1))
679   -- -- evec is (TFVec n), so it still needs an element type
680   -- let (nvec, _) = splitAppTy (Var.varType vec)
681   -- -- Put the type of the start value in nvec, this will be the type of our
682   -- -- temporary vector
683   let tmp_ty = Var.varType res
684   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
685   tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
686   -- Setup the generate scheme
687   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
688   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
689   let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
690   let gen_scheme   = AST.ForGn n_id gen_range
691   -- Make the intermediate vector
692   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
693   -- Create the generate statement
694   cells' <- sequence [genFirstCell, genOtherCell]
695   let (cells, useds) = unzip cells'
696   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
697   -- Assign tmp[len-1] or tmp[0] to res
698   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name    
699   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
700   return ([AST.CSBSm block], concat useds)
701   where
702     -- An id for the counter
703     n_id = mkVHDLBasicId "n"
704     n_cur = idToVHDLExpr n_id
705     -- An expression for previous n
706     n_prev = n_cur AST.:-: (AST.PrimLit "1")
707     -- An id for the tmp result vector
708     tmp_id = mkVHDLBasicId "tmp"
709     tmp_name = AST.NSimple tmp_id
710     -- Generate parts of the fold
711     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
712     genFirstCell = do
713       let cond_label = mkVHDLExtId "firstcell"
714       -- if n == 0 or n == len-1
715       let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
716       -- Output to tmp[current n]
717       let resname = mkIndexedName tmp_name n_cur
718       -- Input from start
719       argexpr <- MonadState.lift tsType $ varToVHDLExpr start
720       let startassign = mkUncondAssign (Right resname) argexpr
721       (app_concsms, used) <- genApplication (Right resname) app_f  [Right argexpr]
722       -- Return the conditional generate part
723       let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then 
724                                                           [startassign]
725                                                          else 
726                                                           app_concsms
727                                                         )
728       return (gensm, used)
729
730     genOtherCell = do
731       let cond_label = mkVHDLExtId "othercell"
732       -- if n > 0 or n < len-1
733       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
734       -- Output to tmp[current n]
735       let resname = mkIndexedName tmp_name n_cur
736       -- Input from tmp[previous n]
737       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
738       (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
739       -- Return the conditional generate part
740       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
741
742
743 -----------------------------------------------------------------------------
744 -- Function to generate VHDL for applications
745 -----------------------------------------------------------------------------
746 genApplication ::
747   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
748   -> CoreSyn.CoreBndr -- ^ The function to apply
749   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
750   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
751   -- ^ The corresponding VHDL concurrent statements and entities
752   --   instantiated.
753 genApplication dst f args = do
754   case Var.isGlobalId f of
755     False -> do 
756       top <- isTopLevelBinder f
757       case top of
758         True -> do
759           -- Local binder that references a top level binding.  Generate a
760           -- component instantiation.
761           signature <- getEntity f
762           args' <- eitherCoreOrExprArgs args
763           let entity_id = ent_id signature
764           -- TODO: Using show here isn't really pretty, but we'll need some
765           -- unique-ish value...
766           let label = "comp_ins_" ++ (either show prettyShow) dst
767           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
768           return ([mkComponentInst label entity_id portmaps], [f])
769         False -> do
770           -- Not a top level binder, so this must be a local variable reference.
771           -- It should have a representable type (and thus, no arguments) and a
772           -- signal should be generated for it. Just generate an unconditional
773           -- assignment here.
774           f' <- MonadState.lift tsType $ varToVHDLExpr f
775           return $ ([mkUncondAssign dst f'], [])
776     True ->
777       case Var.idDetails f of
778         IdInfo.DataConWorkId dc -> case dst of
779           -- It's a datacon. Create a record from its arguments.
780           Left bndr -> do
781             -- We have the bndr, so we can get at the type
782             labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
783             args' <- eitherCoreOrExprArgs args
784             return $ (zipWith mkassign labels $ args', [])
785             where
786               mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
787               mkassign label arg =
788                 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
789                 mkUncondAssign (Right sel_name) arg
790           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
791         IdInfo.DataConWrapId dc -> case dst of
792           -- It's a datacon. Create a record from its arguments.
793           Left bndr -> do 
794             case (Map.lookup (varToString f) globalNameTable) of
795              Just (arg_count, builder) ->
796               if length args == arg_count then
797                 builder dst f args
798               else
799                 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
800              Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
801           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
802         IdInfo.VanillaId -> do
803           -- It's a global value imported from elsewhere. These can be builtin
804           -- functions. Look up the function name in the name table and execute
805           -- the associated builder if there is any and the argument count matches
806           -- (this should always be the case if it typechecks, but just to be
807           -- sure...).
808           case (Map.lookup (varToString f) globalNameTable) of
809             Just (arg_count, builder) ->
810               if length args == arg_count then
811                 builder dst f args
812               else
813                 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
814             Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
815         IdInfo.ClassOpId cls -> do
816           -- FIXME: Not looking for what instance this class op is called for
817           -- Is quite stupid of course.
818           case (Map.lookup (varToString f) globalNameTable) of
819             Just (arg_count, builder) ->
820               if length args == arg_count then
821                 builder dst f args
822               else
823                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
824             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
825         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
826
827 -----------------------------------------------------------------------------
828 -- Functions to generate functions dealing with vectors.
829 -----------------------------------------------------------------------------
830
831 -- Returns the VHDLId of the vector function with the given name for the given
832 -- element type. Generates -- this function if needed.
833 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
834 vectorFunId el_ty fname = do
835   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
836   elemTM <- vhdl_ty error_msg el_ty
837   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
838   -- the VHDLState or something.
839   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
840   typefuns <- getA tsTypeFuns
841   case Map.lookup (OrdType el_ty, fname) typefuns of
842     -- Function already generated, just return it
843     Just (id, _) -> return id
844     -- Function not generated yet, generate it
845     Nothing -> do
846       let functions = genUnconsVectorFuns elemTM vectorTM
847       case lookup fname functions of
848         Just body -> do
849           modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
850           mapM_ (vectorFunId el_ty) (snd body)
851           return function_id
852         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
853   where
854     function_id = mkVHDLExtId fname
855
856 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
857                     -> AST.TypeMark -- ^ type of the vector
858                     -> [(String, (AST.SubProgBody, [String]))]
859 genUnconsVectorFuns elemTM vectorTM  = 
860   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
861   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
862   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
863   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
864   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[]))
865   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
866   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
867   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
868   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
869   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
870   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
871   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))  
872   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
873   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
874   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
875   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
876   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
877   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
878   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
879   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
880   ]
881   where 
882     ixPar   = AST.unsafeVHDLBasicId "ix"
883     vecPar  = AST.unsafeVHDLBasicId "vec"
884     vec1Par = AST.unsafeVHDLBasicId "vec1"
885     vec2Par = AST.unsafeVHDLBasicId "vec2"
886     nPar    = AST.unsafeVHDLBasicId "n"
887     iId     = AST.unsafeVHDLBasicId "i"
888     iPar    = iId
889     aPar    = AST.unsafeVHDLBasicId "a"
890     fPar = AST.unsafeVHDLBasicId "f"
891     sPar = AST.unsafeVHDLBasicId "s"
892     resId   = AST.unsafeVHDLBasicId "res"
893     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
894                                AST.IfaceVarDec ixPar  naturalTM] elemTM
895     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
896               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $ 
897                 AST.NSimple ixPar]))
898     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
899                                           , AST.IfaceVarDec iPar   naturalTM
900                                           , AST.IfaceVarDec aPar   elemTM
901                                           ] vectorTM 
902        -- variable res : fsvec_x (0 to vec'length-1);
903     replaceVar =
904          AST.VarDec resId 
905                 (AST.SubtypeIn vectorTM
906                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
907                    [AST.ToRange (AST.PrimLit "0")
908                             (AST.PrimName (AST.NAttribute $ 
909                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
910                                 (AST.PrimLit "1"))   ]))
911                 Nothing
912        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
913     replaceExpr = AST.NSimple resId AST.:=
914            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
915             AST.PrimName (AST.NSimple aPar) AST.:&: 
916              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
917                       ((AST.PrimName (AST.NAttribute $ 
918                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)) 
919                                                               AST.:-: AST.PrimLit "1"))
920     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
921     vecSlice init last =  AST.PrimName (AST.NSlice 
922                                         (AST.SliceName 
923                                               (AST.NSimple vecPar) 
924                                               (AST.ToRange init last)))
925     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
926        -- return vec(vec'length-1);
927     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName 
928                     (AST.NSimple vecPar) 
929                     [AST.PrimName (AST.NAttribute $ 
930                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
931                                                              AST.:-: AST.PrimLit "1"])))
932     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
933        -- variable res : fsvec_x (0 to vec'length-2);
934     initVar = 
935          AST.VarDec resId 
936                 (AST.SubtypeIn vectorTM
937                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
938                    [AST.ToRange (AST.PrimLit "0")
939                             (AST.PrimName (AST.NAttribute $ 
940                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
941                                 (AST.PrimLit "2"))   ]))
942                 Nothing
943        -- resAST.:= vec(0 to vec'length-2)
944     initExpr = AST.NSimple resId AST.:= (vecSlice 
945                                (AST.PrimLit "0") 
946                                (AST.PrimName (AST.NAttribute $ 
947                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
948                                                              AST.:-: AST.PrimLit "2"))
949     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
950     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
951                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
952        -- variable res : fsvec_x (0 to n-1);
953     takeVar = 
954          AST.VarDec resId 
955                 (AST.SubtypeIn vectorTM
956                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
957                    [AST.ToRange (AST.PrimLit "0")
958                                ((AST.PrimName (AST.NSimple nPar)) AST.:-:
959                                 (AST.PrimLit "1"))   ]))
960                 Nothing
961        -- res AST.:= vec(0 to n-1)
962     takeExpr = AST.NSimple resId AST.:= 
963                     (vecSlice (AST.PrimLit "1") 
964                               (AST.PrimName (AST.NSimple $ nPar) AST.:-: AST.PrimLit "1"))
965     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
966     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
967                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM 
968        -- variable res : fsvec_x (0 to vec'length-n-1);
969     dropVar = 
970          AST.VarDec resId 
971                 (AST.SubtypeIn vectorTM
972                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
973                    [AST.ToRange (AST.PrimLit "0")
974                             (AST.PrimName (AST.NAttribute $ 
975                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
976                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
977                Nothing
978        -- res AST.:= vec(n to vec'length-1)
979     dropExpr = AST.NSimple resId AST.:= (vecSlice 
980                                (AST.PrimName $ AST.NSimple nPar) 
981                                (AST.PrimName (AST.NAttribute $ 
982                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
983                                                              AST.:-: AST.PrimLit "1"))
984     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
985     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
986                                        AST.IfaceVarDec vecPar vectorTM] vectorTM 
987     -- variable res : fsvec_x (0 to vec'length);
988     plusgtVar = 
989       AST.VarDec resId 
990              (AST.SubtypeIn vectorTM
991                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
992                 [AST.ToRange (AST.PrimLit "0")
993                         (AST.PrimName (AST.NAttribute $ 
994                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
995              Nothing
996     plusgtExpr = AST.NSimple resId AST.:= 
997                    ((AST.PrimName $ AST.NSimple aPar) AST.:&: 
998                     (AST.PrimName $ AST.NSimple vecPar))
999     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1000     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1001     emptyVar = 
1002           AST.ConstDec resId 
1003               (AST.SubtypeIn vectorTM Nothing)
1004               (Just $ AST.PrimLit "\"\"")
1005     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1006     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ] 
1007                                          vectorTM
1008     -- variable res : fsvec_x (0 to 0) := (others => a);
1009     singletonVar = 
1010       AST.VarDec resId 
1011              (AST.SubtypeIn vectorTM
1012                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1013                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1014              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
1015                                           (AST.PrimName $ AST.NSimple aPar)])
1016     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1017     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1018                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM 
1019     -- variable res : fsvec_x (0 to n-1) := (others => a);
1020     copynVar = 
1021       AST.VarDec resId 
1022              (AST.SubtypeIn vectorTM
1023                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1024                 [AST.ToRange (AST.PrimLit "0")
1025                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1026                              (AST.PrimLit "1"))   ]))
1027              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
1028                                           (AST.PrimName $ AST.NSimple aPar)])
1029     -- return res
1030     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1031     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1032                                AST.IfaceVarDec sPar   naturalTM,
1033                                AST.IfaceVarDec nPar   naturalTM,
1034                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1035     -- variable res : fsvec_x (0 to n-1);
1036     selVar = 
1037       AST.VarDec resId 
1038                 (AST.SubtypeIn vectorTM
1039                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1040                     [AST.ToRange (AST.PrimLit "0")
1041                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1042                       (AST.PrimLit "1"))   ])
1043                 )
1044                 Nothing
1045     -- for i res'range loop
1046     --   res(i) := vec(f+i*s);
1047     -- end loop;
1048     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1049     -- res(i) := vec(f+i*s);
1050     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: 
1051                                 (AST.PrimName (AST.NSimple iId) AST.:*: 
1052                                   AST.PrimName (AST.NSimple sPar)) in
1053                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1054                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1055     -- return res;
1056     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1057     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1058                                         AST.IfaceVarDec aPar   elemTM] vectorTM 
1059      -- variable res : fsvec_x (0 to vec'length);
1060     ltplusVar = 
1061       AST.VarDec resId 
1062         (AST.SubtypeIn vectorTM
1063           (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1064             [AST.ToRange (AST.PrimLit "0")
1065               (AST.PrimName (AST.NAttribute $ 
1066                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1067         Nothing
1068     ltplusExpr = AST.NSimple resId AST.:= 
1069                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&: 
1070                       (AST.PrimName $ AST.NSimple aPar))
1071     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1072     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1073                                              AST.IfaceVarDec vec2Par vectorTM] 
1074                                              vectorTM 
1075     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1076     plusplusVar = 
1077       AST.VarDec resId 
1078         (AST.SubtypeIn vectorTM
1079           (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1080             [AST.ToRange (AST.PrimLit "0")
1081               (AST.PrimName (AST.NAttribute $ 
1082                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1083                   AST.PrimName (AST.NAttribute $ 
1084                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1085                   AST.PrimLit "1")]))
1086        Nothing
1087     plusplusExpr = AST.NSimple resId AST.:= 
1088                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&: 
1089                       (AST.PrimName $ AST.NSimple vec2Par))
1090     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1091     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1092     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ 
1093                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1094     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1095                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM 
1096     -- variable res : fsvec_x (0 to vec'length-1);
1097     shiftlVar = 
1098      AST.VarDec resId 
1099             (AST.SubtypeIn vectorTM
1100               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1101                [AST.ToRange (AST.PrimLit "0")
1102                         (AST.PrimName (AST.NAttribute $ 
1103                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1104                            (AST.PrimLit "1")) ]))
1105             Nothing
1106     -- res := a & init(vec)
1107     shiftlExpr = AST.NSimple resId AST.:=
1108                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1109                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
1110                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1111     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
1112     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1113                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM 
1114     -- variable res : fsvec_x (0 to vec'length-1);
1115     shiftrVar = 
1116      AST.VarDec resId 
1117             (AST.SubtypeIn vectorTM
1118               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1119                [AST.ToRange (AST.PrimLit "0")
1120                         (AST.PrimName (AST.NAttribute $ 
1121                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1122                            (AST.PrimLit "1")) ]))
1123             Nothing
1124     -- res := tail(vec) & a
1125     shiftrExpr = AST.NSimple resId AST.:=
1126                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
1127                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1128                   (AST.PrimName (AST.NSimple aPar)))
1129                 
1130     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)      
1131     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1132     -- return vec'length = 0
1133     nullExpr = AST.ReturnSm (Just $ 
1134                 AST.PrimName (AST.NAttribute $ 
1135                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1136                     AST.PrimLit "0")
1137     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
1138     -- variable res : fsvec_x (0 to vec'length-1);
1139     rotlVar = 
1140      AST.VarDec resId 
1141             (AST.SubtypeIn vectorTM
1142               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1143                [AST.ToRange (AST.PrimLit "0")
1144                         (AST.PrimName (AST.NAttribute $ 
1145                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1146                            (AST.PrimLit "1")) ]))
1147             Nothing
1148     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1149     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
1150                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1151                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1152                         []
1153                         (Just $ AST.Else [rotlExprRet])
1154       where rotlExprRet = 
1155                 AST.NSimple resId AST.:= 
1156                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))  
1157                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1158                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
1159                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1160     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
1161     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
1162     -- variable res : fsvec_x (0 to vec'length-1);
1163     rotrVar = 
1164      AST.VarDec resId 
1165             (AST.SubtypeIn vectorTM
1166               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1167                [AST.ToRange (AST.PrimLit "0")
1168                         (AST.PrimName (AST.NAttribute $ 
1169                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1170                            (AST.PrimLit "1")) ]))
1171             Nothing
1172     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1173     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
1174                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1175                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1176                         []
1177                         (Just $ AST.Else [rotrExprRet])
1178       where rotrExprRet = 
1179                 AST.NSimple resId AST.:= 
1180                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
1181                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1182                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))  
1183                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1184     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1185     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1186     reverseVar = 
1187       AST.VarDec resId 
1188              (AST.SubtypeIn vectorTM
1189                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1190                 [AST.ToRange (AST.PrimLit "0")
1191                          (AST.PrimName (AST.NAttribute $ 
1192                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1193                             (AST.PrimLit "1")) ]))
1194              Nothing
1195     -- for i in 0 to res'range loop
1196     --   res(vec'length-i-1) := vec(i);
1197     -- end loop;
1198     reverseFor = 
1199        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1200     -- res(vec'length-i-1) := vec(i);
1201     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1202       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) 
1203                            [AST.PrimName $ AST.NSimple iId]))
1204         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) 
1205                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: 
1206                         AST.PrimName (AST.NSimple iId) AST.:-: 
1207                         (AST.PrimLit "1") 
1208     -- return res;
1209     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1210
1211     
1212 -----------------------------------------------------------------------------
1213 -- A table of builtin functions
1214 -----------------------------------------------------------------------------
1215
1216 -- A function that generates VHDL for a builtin function
1217 type BuiltinBuilder = 
1218   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1219   -> CoreSyn.CoreBndr -- ^ The function called
1220   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1221                     --   dictionary arguments).
1222   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
1223   -- ^ The corresponding VHDL concurrent statements and entities
1224   --   instantiated.
1225
1226 -- A map of a builtin function to VHDL function builder 
1227 type NameTable = Map.Map String (Int, BuiltinBuilder )
1228
1229 -- | The builtin functions we support. Maps a name to an argument count and a
1230 -- builder function.
1231 globalNameTable :: NameTable
1232 globalNameTable = Map.fromList
1233   [ (exId             , (2, genFCall False          ) )
1234   , (replaceId        , (3, genFCall False          ) )
1235   , (headId           , (1, genFCall True           ) )
1236   , (lastId           , (1, genFCall True           ) )
1237   , (tailId           , (1, genFCall False          ) )
1238   , (initId           , (1, genFCall False          ) )
1239   , (takeId           , (2, genFCall False          ) )
1240   , (dropId           , (2, genFCall False          ) )
1241   , (selId            , (4, genFCall False          ) )
1242   , (plusgtId         , (2, genFCall False          ) )
1243   , (ltplusId         , (2, genFCall False          ) )
1244   , (plusplusId       , (2, genFCall False          ) )
1245   , (mapId            , (2, genMap                  ) )
1246   , (zipWithId        , (3, genZipWith              ) )
1247   , (foldlId          , (3, genFoldl                ) )
1248   , (foldrId          , (3, genFoldr                ) )
1249   , (zipId            , (2, genZip                  ) )
1250   , (unzipId          , (1, genUnzip                ) )
1251   , (shiftlId         , (2, genFCall False          ) )
1252   , (shiftrId         , (2, genFCall False          ) )
1253   , (rotlId           , (1, genFCall False          ) )
1254   , (rotrId           , (1, genFCall False          ) )
1255   , (concatId         , (1, genConcat               ) )
1256   , (reverseId        , (1, genFCall False          ) )
1257   , (iteratenId       , (3, genIteraten             ) )
1258   , (iterateId        , (2, genIterate              ) )
1259   , (generatenId      , (3, genGeneraten            ) )
1260   , (generateId       , (2, genGenerate             ) )
1261   , (emptyId          , (0, genFCall False          ) )
1262   , (singletonId      , (1, genFCall False          ) )
1263   , (copynId          , (2, genFCall False          ) )
1264   , (copyId           , (1, genCopy                 ) )
1265   , (lengthTId        , (1, genFCall False          ) )
1266   , (nullId           , (1, genFCall False          ) )
1267   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1268   , (hwandId          , (2, genOperator2 AST.And    ) )
1269   , (hworId           , (2, genOperator2 AST.Or     ) )
1270   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1271   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1272   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
1273   , (negateId         , (1, genNegation             ) )
1274   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1275   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1276   , (fromIntegerId    , (1, genFromInteger          ) )
1277   , (resizeId         , (1, genResize               ) )
1278   , (sizedIntId       , (1, genSizedInt             ) )
1279   --, (tfvecId          , (1, genTFVec                ) )
1280   ]