191ae9cf5a6e9242b54d6bbcec17047ac3c3bbfb
[matthijs/master-project/cλash.git] / clash / CLasH / VHDL / 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 qualified Data.Accessor.Monad.Trans.State as MonadState
10
11 -- VHDL Imports
12 import qualified Language.VHDL.AST as AST
13
14 -- GHC API
15 import qualified CoreSyn
16 import qualified Type
17 import qualified Var
18 import qualified Id
19 import qualified IdInfo
20 import qualified Literal
21 import qualified Name
22 import qualified TyCon
23 import qualified CoreUtils
24
25 -- Local imports
26 import CLasH.Translator.TranslatorTypes
27 import CLasH.VHDL.Constants
28 import CLasH.VHDL.VHDLTypes
29 import CLasH.VHDL.VHDLTools
30 import CLasH.Utils
31 import CLasH.Utils.Core.CoreTools
32 import CLasH.Utils.Pretty
33 import qualified CLasH.Normalize as Normalize
34
35 -----------------------------------------------------------------------------
36 -- Functions to generate VHDL for user-defined functions.
37 -----------------------------------------------------------------------------
38
39 -- | Create an entity for a given function
40 getEntity ::
41   CoreSyn.CoreBndr
42   -> TranslatorSession Entity -- ^ The resulting entity
43
44 getEntity fname = makeCached fname tsEntities $ do
45       expr <- Normalize.getNormalized False fname
46       -- Split the normalized expression
47       let (args, binds, res) = Normalize.splitNormalized expr
48       -- Generate ports for all non-empty types
49       args' <- catMaybesM $ mapM mkMap args
50       -- TODO: Handle Nothing
51       res' <- mkMap res
52       count <- MonadState.get tsEntityCounter 
53       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "Component_" ++ show count
54       MonadState.set tsEntityCounter (count + 1)
55       let ent_decl = createEntityAST vhdl_id args' res'
56       let signature = Entity vhdl_id args' res' ent_decl
57       return signature
58   where
59     mkMap ::
60       --[(SignalId, SignalInfo)] 
61       CoreSyn.CoreBndr 
62       -> TranslatorSession (Maybe Port)
63     mkMap = (\bndr ->
64       let
65         --info = Maybe.fromMaybe
66         --  (error $ "Signal not found in the name map? This should not happen!")
67         --  (lookup id sigmap)
68         --  Assume the bndr has a valid VHDL id already
69         id = varToVHDLId bndr
70         ty = Var.varType bndr
71         error_msg = "\nVHDL.createEntity.mkMap: Can not create entity: " ++ pprString fname ++ "\nbecause no type can be created for port: " ++ pprString bndr 
72       in do
73         type_mark_maybe <- MonadState.lift tsType $ vhdlTy error_msg ty
74         case type_mark_maybe of 
75           Just type_mark -> return $ Just (id, type_mark)
76           Nothing -> return Nothing
77      )
78
79 -- | Create the VHDL AST for an entity
80 createEntityAST ::
81   AST.VHDLId                   -- ^ The name of the function
82   -> [Port]                    -- ^ The entity's arguments
83   -> Maybe Port                -- ^ The entity's result
84   -> AST.EntityDec             -- ^ The entity with the ent_decl filled in as well
85
86 createEntityAST vhdl_id args res =
87   AST.EntityDec vhdl_id ports
88   where
89     -- Create a basic Id, since VHDL doesn't grok filenames with extended Ids.
90     ports = map (mkIfaceSigDec AST.In) args
91               ++ (Maybe.maybeToList res_port)
92               ++ [clk_port,resetn_port]
93     -- Add a clk port if we have state
94     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
95     resetn_port = AST.IfaceSigDec resetId AST.In std_logicTM
96     res_port = fmap (mkIfaceSigDec AST.Out) res
97
98 -- | Create a port declaration
99 mkIfaceSigDec ::
100   AST.Mode                         -- ^ The mode for the port (In / Out)
101   -> Port                          -- ^ The id and type for the port
102   -> AST.IfaceSigDec               -- ^ The resulting port declaration
103
104 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
105
106 -- | Create an architecture for a given function
107 getArchitecture ::
108   CoreSyn.CoreBndr -- ^ The function to get an architecture for
109   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
110   -- ^ The architecture for this function
111
112 getArchitecture fname = makeCached fname tsArchitectures $ do
113   expr <- Normalize.getNormalized False fname
114   -- Split the normalized expression
115   let (args, binds, res) = Normalize.splitNormalized expr
116   
117   -- Get the entity for this function
118   signature <- getEntity fname
119   let entity_id = ent_id signature
120
121   -- Create signal declarations for all binders in the let expression, except
122   -- for the output port (that will already have an output port declared in
123   -- the entity).
124   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
125   let sig_decs = Maybe.catMaybes sig_dec_maybes
126   -- Process each bind, resulting in info about state variables and concurrent
127   -- statements.
128   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
129   let (in_state_maybes, out_state_maybes) = unzip state_vars
130   let (statementss, used_entitiess) = unzip sms
131   -- Get initial state, if it's there
132   initSmap <- MonadState.get tsInitStates
133   let init_state = Map.lookup fname initSmap
134   -- Create a state proc, if needed
135   (state_proc, resbndr) <- case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes, init_state) of
136         ([in_state], [out_state], Nothing) -> do 
137           nonEmpty <- hasNonEmptyType in_state
138           if nonEmpty 
139             then error ("No initial state defined for: " ++ show fname) 
140             else return ([],[])
141         ([in_state], [out_state], Just resetval) -> do
142           nonEmpty <- hasNonEmptyType in_state
143           if nonEmpty 
144             then mkStateProcSm (in_state, out_state, resetval)
145             else error ("Initial state defined for function with only substate: " ++ show fname)
146         ([], [], Just _) -> error $ "Initial state defined for state-less function: " ++ show fname
147         ([], [], Nothing) -> return ([],[])
148         (ins, outs, res) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
149   -- Join the create statements and the (optional) state_proc
150   let statements = concat statementss ++ state_proc
151   -- Create the architecture
152   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
153   let used_entities = (concat used_entitiess) ++ resbndr
154   return (arch, used_entities)
155   where
156     dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
157               -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
158               -- ^ ((Input state variable, output state variable), (statements, used entities))
159     -- newtype unpacking is just a cast
160     dobind (bndr, unpacked@(CoreSyn.Cast packed coercion)) 
161       | hasStateType packed && not (hasStateType unpacked)
162       = return ((Just bndr, Nothing), ([], []))
163     -- With simplCore, newtype packing is just a cast
164     dobind (bndr, packed@(CoreSyn.Cast unpacked@(CoreSyn.Var state) coercion)) 
165       | hasStateType packed && not (hasStateType unpacked)
166       = return ((Nothing, Just state), ([], []))
167     -- Without simplCore, newtype packing uses a data constructor
168     dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state))) 
169       | isStateCon con
170       = return ((Nothing, Just state), ([], []))
171     -- Anything else is handled by mkConcSm
172     dobind bind = do
173       sms <- mkConcSm bind
174       return ((Nothing, Nothing), sms)
175
176 mkStateProcSm :: 
177   (CoreSyn.CoreBndr, CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current state, new state and reset variables
178   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) -- ^ The resulting statements
179 mkStateProcSm (old, new, res) = do
180   let error_msg = "\nVHDL.mkSigDec: Can not make signal declaration for type: \n" ++ pprString res 
181   type_mark_old_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType old)
182   let type_mark_old = Maybe.fromMaybe 
183                         (error $ "\nGenerate.mkStateProcSm: empty type for state? Type: " ++ pprString (Var.varType old))
184                         type_mark_old_maybe
185   type_mark_res_maybe <- MonadState.lift tsType $ vhdlTy error_msg (Var.varType res)
186   let type_mark_res' = Maybe.fromMaybe 
187                         (error $ "\nGenerate.mkStateProcSm: empty type for initial state? Type: " ++ pprString (Var.varType res))
188                         type_mark_res_maybe
189   let type_mark_res = if type_mark_old == type_mark_res' then
190                         type_mark_res'
191                       else 
192                         error $ "Initial state has different type than state type, state type: " ++ show type_mark_old ++ ", init type: "  ++ show type_mark_res'    
193   let resvalid  = mkVHDLExtId $ varToString res ++ "val"
194   let resvaldec = AST.BDISD $ AST.SigDec resvalid type_mark_res Nothing
195   let reswform  = AST.Wform [AST.WformElem (AST.PrimName $ AST.NSimple resvalid) Nothing]
196   let res_assign = AST.SigAssign (varToVHDLName old) reswform
197   let blocklabel       = mkVHDLBasicId "state"
198   let statelabel  = mkVHDLBasicId "stateupdate"
199   let rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
200   let wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
201   let clk_assign      = AST.SigAssign (varToVHDLName old) wform
202   let rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clockId)]
203   let resetn_is_low  = (AST.PrimName $ AST.NSimple resetId) AST.:=: (AST.PrimLit "'0'")
204   signature <- getEntity res
205   let entity_id = ent_id signature
206   let reslabel = "resetval_" ++ ((prettyShow . varToVHDLName) res)
207   let portmaps = mkAssocElems [] (AST.NSimple resvalid) signature
208   let reset_statement = mkComponentInst reslabel entity_id portmaps
209   let clk_statement = [AST.ElseIf rising_edge_clk [clk_assign]]
210   let statement   = AST.IfSm resetn_is_low [res_assign] clk_statement Nothing
211   let stateupdate = AST.CSPSm $ AST.ProcSm statelabel [clockId,resetId,resvalid] [statement]
212   let block = AST.CSBSm $ AST.BlockSm blocklabel [] (AST.PMapAspect []) [resvaldec] [reset_statement,stateupdate]
213   return ([block],[res])
214
215 -- | Transforms a core binding into a VHDL concurrent statement
216 mkConcSm ::
217   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
218   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
219   -- ^ The corresponding VHDL concurrent statements and entities
220   --   instantiated.
221
222
223 -- Ignore Cast expressions, they should not longer have any meaning as long as
224 -- the type works out. Throw away state repacking
225 mkConcSm (bndr, to@(CoreSyn.Cast from ty))
226   | hasStateType to && hasStateType from
227   = return ([],[])
228 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
229
230 -- Simple a = b assignments are just like applications, but without arguments.
231 -- We can't just generate an unconditional assignment here, since b might be a
232 -- top level binding (e.g., a function with no arguments).
233 mkConcSm (bndr, CoreSyn.Var v) = do
234   genApplication (Left bndr, Var.varType bndr) v []
235
236 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
237   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
238   let valargs = get_val_args (Var.varType f) args
239   genApplication (Left bndr, Var.varType bndr) f (zip (map Left valargs) (map CoreUtils.exprType valargs))
240
241 -- A single alt case must be a selector. This means the scrutinee is a simple
242 -- variable, the alternative is a dataalt with a single non-wild binder that
243 -- is also returned.
244 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt])) 
245                 -- Don't generate VHDL for substate extraction
246                 | hasStateType bndr = return ([], [])
247                 | otherwise =
248   case alt of
249     (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
250       nonemptysel <- hasNonEmptyType sel_bndr 
251       if nonemptysel 
252         then do
253           bndrs' <- Monad.filterM hasNonEmptyType bndrs
254           case List.elemIndex sel_bndr bndrs' of
255             Just sel_i -> do
256               htypeScrt <- MonadState.lift tsType $ mkHTypeEither (Var.varType scrut)
257               htypeBndr <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
258               case htypeScrt == htypeBndr of
259                 True -> do
260                   let sel_name = varToVHDLName scrut
261                   let sel_expr = AST.PrimName sel_name
262                   return ([mkUncondAssign (Left bndr) sel_expr], [])
263                 otherwise ->
264                   case htypeScrt of
265                     Right htype@(AggrType _ _ _) -> do
266                       let dc_i = datacon_index (Id.idType scrut) dc
267                       let labels = getFieldLabels htype dc_i
268                       let label = labels!!sel_i
269                       let sel_name = mkSelectedName (varToVHDLName scrut) label
270                       let sel_expr = AST.PrimName sel_name
271                       return ([mkUncondAssign (Left bndr) sel_expr], [])
272                     _ -> do -- error $ "DIE!"
273                       let sel_name = varToVHDLName scrut
274                       let sel_expr = AST.PrimName sel_name
275                       return ([mkUncondAssign (Left bndr) sel_expr], [])
276             Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case: result is not one of the binders\n" ++ (pprString expr)
277           else
278             -- A selector case that selects a state value, ignore it.
279             return ([], [])
280       
281     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
282
283 -- Multiple case alt become conditional assignments and have only wild
284 -- binders in the alts and only variables in the case values and a variable
285 -- for a scrutinee. We check the constructor of the second alt, since the
286 -- first is the default case, if there is any.
287 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) _ _ alts)) = do
288   htype <- MonadState.lift tsType $ mkHType ("\nVHDL.mkConcSm: Unrepresentable scrutinee type? Expression: " ++ pprString expr) scrut
289   -- Turn the scrutinee into a VHDLExpr
290   scrut_expr <- MonadState.lift tsType $ varToVHDLExpr scrut
291   (enums, cmp) <- case htype of
292     EnumType _ enums -> do
293       -- Enumeration type, compare with the scrutinee directly
294       return (map (AST.PrimLit . show) [0..(length enums)-1], scrut_expr)
295     AggrType _ (Just (name, EnumType _ enums)) _ -> do
296       -- Extract the enumeration field from the aggregation
297       let sel_name = mkSelectedName (varToVHDLName scrut) (mkVHDLBasicId name)
298       let sel_expr = AST.PrimName sel_name
299       return (map (AST.PrimLit . show) [0..(length enums)-1], sel_expr)
300     (BuiltinType "Bit") -> do
301       let enums = [AST.PrimLit "'1'", AST.PrimLit "'0'"]
302       return (enums, scrut_expr)
303     (BuiltinType "Bool") -> do
304       let enums = [AST.PrimLit "true", AST.PrimLit "false"]
305       return (enums, scrut_expr)
306     _ -> error $ "\nSelector case on weird scrutinee: " ++ pprString scrut ++ " scrutinee type: " ++ pprString (Id.idType scrut)
307   -- Omit first condition, which is the default. Look up each altcon in
308   -- the enums list from the HType to find the actual enum value names.
309   let altcons = map (\(CoreSyn.DataAlt dc, _, _) -> enums!!(datacon_index scrut dc)) (tail alts)
310   -- Compare the (constructor field of the) scrutinee with each of the
311   -- alternatives.
312   let cond_exprs = map (\x -> cmp AST.:=: x) altcons
313   -- Rotate expressions to the left, so that the expression related to the default case is the last
314   exprs <- MonadState.lift tsType $ mapM (varToVHDLExpr . (\(_,_,CoreSyn.Var expr) -> expr)) ((tail alts) ++ [head alts])
315   return ([mkAltsAssign (Left bndr) cond_exprs exprs], [])
316
317 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement does not have a simple variable as scrutinee"
318 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
319
320 -----------------------------------------------------------------------------
321 -- Functions to generate VHDL for builtin functions
322 -----------------------------------------------------------------------------
323
324 -- | A function to wrap a builder-like function that expects its arguments to
325 -- be expressions.
326 genExprArgs wrap dst func args = do
327   args' <- argsToVHDLExprs (map fst args)
328   wrap dst func (zip args' (map snd args))
329
330 -- | Turn the all lefts into VHDL Expressions.
331 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
332 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
333
334 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
335 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
336   let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
337   ty_maybe <- vhdlTy errmsg expr
338   case ty_maybe of
339     Just _ -> do
340       vhdl_expr <- varToVHDLExpr $ exprToVar expr
341       return $ Just vhdl_expr
342     Nothing -> return Nothing
343
344 argToVHDLExpr (Right expr) = return $ Just expr
345
346 -- A function to wrap a builder-like function that generates no component
347 -- instantiations
348 genNoInsts ::
349   (dst -> func -> args -> TranslatorSession [AST.ConcSm])
350   -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
351 genNoInsts wrap dst func args = do
352   concsms <- wrap dst func args
353   return (concsms, [])
354
355 -- | A function to wrap a builder-like function that expects its arguments to
356 -- be variables.
357 -- genVarArgs ::
358 --   (dst -> func -> [Var.Var] -> res)
359 --   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
360 -- genVarArgs wrap = genCoreArgs $ \dst func args -> let
361 --     args' = map exprToVar args
362 --   in
363 --     wrap dst func args'
364
365 -- | A function to wrap a builder-like function that expects its arguments to
366 -- be core expressions.
367 genCoreArgs ::
368   (dst -> func -> [CoreSyn.CoreExpr] -> res)
369   -> (dst -> func -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> res)
370 genCoreArgs wrap dst func args = wrap dst func args'
371   where
372     -- Check (rather crudely) that all arguments are CoreExprs
373     args' = case Either.partitionEithers (map fst args) of 
374       (exprargs, []) -> exprargs
375       (exprsargs, rest) -> error $ "\nGenerate.genCoreArgs: expect core expression arguments but found ast exprs:" ++ (show rest)
376
377 -- | A function to wrap a builder-like function that produces an expression
378 -- and expects it to be assigned to the destination.
379 genExprRes ::
380   ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
381   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
382 genExprRes wrap dst func args = do
383   expr <- wrap dst func args
384   return [mkUncondAssign dst expr]
385
386 -- | Generate a binary operator application. The first argument should be a
387 -- constructor from the AST.Expr type, e.g. AST.And.
388 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder 
389 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
390 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
391 genOperator2' op _ f [(arg1,_), (arg2,_)] = return $ op arg1 arg2
392
393 -- | Generate a unary operator application
394 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder 
395 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
396 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
397 genOperator1' op _ f [(arg,_)] = return $ op arg
398
399 -- | Generate a unary operator application
400 genNegation :: BuiltinBuilder 
401 genNegation = genNoInsts $ genExprRes genNegation'
402 genNegation' :: dst -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
403 genNegation' _ f [(arg,argType)] = do
404   [arg1] <-  argsToVHDLExprs [arg]
405   let (tycon, args) = Type.splitTyConApp argType
406   let name = Name.getOccString (TyCon.tyConName tycon)
407   case name of
408     "Signed" -> return $ AST.Neg arg1
409     otherwise -> error $ "\nGenerate.genNegation': Negation not allowed for type: " ++ show name 
410
411 -- | Generate a function call from the destination binder, function name and a
412 -- list of expressions (its arguments)
413 genFCall :: Bool -> BuiltinBuilder 
414 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
415 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
416 genFCall' switch (Left res) f args = do
417   let fname = varToString f
418   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
419   id <- MonadState.lift tsType $ vectorFunId el_ty fname
420   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
421              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) (map fst args)
422 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
423
424 genFromSizedWord :: BuiltinBuilder
425 genFromSizedWord = genNoInsts $ genExprArgs genFromSizedWord'
426 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
427 genFromSizedWord' (Left res) f args@[(arg,_)] =
428   return [mkUncondAssign (Left res) arg]
429   -- let fname = varToString f
430   -- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
431   --            map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
432 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
433
434 genFromRangedWord :: BuiltinBuilder
435 genFromRangedWord = genNoInsts $ genExprArgs $ genExprRes genFromRangedWord'
436 genFromRangedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
437 genFromRangedWord' (Left res) f [(arg,_)] = do {
438   ; let { ty = Var.varType res
439         ; (tycon, args) = Type.splitTyConApp ty
440         ; name = Name.getOccString (TyCon.tyConName tycon)
441         } ;
442   ; len <- MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
443   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
444              [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
445   }
446 genFromRangedWord' (Right name) _ _ = error $ "\nGenerate.genFromRangedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
447
448 genResize :: BuiltinBuilder
449 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
450 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
451 genResize' (Left res) f [(arg,_)] = do {
452   ; let { ty = Var.varType res
453         ; (tycon, args) = Type.splitTyConApp ty
454         ; name = Name.getOccString (TyCon.tyConName tycon)
455         } ;
456   ; len <- case name of
457       "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
458       "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
459   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
460              [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
461   }
462 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
463
464 genTimes :: BuiltinBuilder
465 genTimes = genNoInsts $ genExprArgs $ genExprRes genTimes'
466 genTimes' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
467 genTimes' (Left res) f [(arg1,_),(arg2,_)] = do {
468   ; let { ty = Var.varType res
469         ; (tycon, args) = Type.splitTyConApp ty
470         ; name = Name.getOccString (TyCon.tyConName tycon)
471         } ;
472   ; len <- case name of
473       "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
474       "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
475       "Index" -> do {  ubound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
476                          ;  let bitsize = floor (logBase 2 (fromInteger (toInteger ubound)))
477                          ;  return bitsize
478                          }
479   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
480              [Nothing AST.:=>: AST.ADExpr (arg1 AST.:*: arg2), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
481   }
482 genTimes' (Right name) _ _ = error $ "\nGenerate.genTimes': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
483
484 -- fromInteger turns an Integer into a Num instance. Since Integer is
485 -- not representable and is only allowed for literals, the actual
486 -- Integer should be inlined entirely into the fromInteger argument.
487 genFromInteger :: BuiltinBuilder
488 genFromInteger = genNoInsts $ genCoreArgs $ genExprRes genFromInteger'
489 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [CoreSyn.CoreExpr] -> TranslatorSession AST.Expr
490 genFromInteger' (Left res) f args = do
491   let ty = Var.varType res
492   let (tycon, tyargs) = Type.splitTyConApp ty
493   let name = Name.getOccString (TyCon.tyConName tycon)
494   len <- case name of
495     "Signed" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
496     "Unsigned" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
497     "Index" -> do
498       bound <- MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
499       return $ floor (logBase 2 (fromInteger (toInteger (bound)))) + 1
500   let fname = case name of "Signed" -> toSignedId ; "Unsigned" -> toUnsignedId ; "Index" -> toUnsignedId
501   case args of
502     [integer] -> do -- The type and dictionary arguments are removed by genApplication
503       literal <- getIntegerLiteral integer
504       return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
505               [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show literal)), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
506     _ -> error $ "\nGenerate.genFromInteger': Wrong number of arguments to genInteger. Applying " ++ pprString f ++ " to " ++ pprString args
507
508 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
509
510 genSizedInt :: BuiltinBuilder
511 genSizedInt = genFromInteger
512
513 {-
514 -- This function is useful for use with vectorTH, since that generates
515 -- explicit references to the TFVec constructor (which is normally
516 -- hidden). Below implementation is probably not current anymore, but
517 -- kept here in case we start using vectorTH again.
518 -- | Generate a Builder for the builtin datacon TFVec
519 genTFVec :: BuiltinBuilder
520 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
521   -- Generate Assignments for all the binders
522   ; letAssigns <- mapM genBinderAssign letBinders
523   -- Generate assignments for the result (which might be another let binding)
524   ; (resBinders,resAssignments) <- genResAssign letRes
525   -- Get all the Assigned binders
526   ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
527   -- Make signal names for all the assigned binders
528   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
529   -- Assign all the signals to the resulting vector
530   ; let { vecsigns = mkAggregateSignal sigs
531         ; vecassign = mkUncondAssign (Left res) vecsigns
532         } ;
533   -- Generate all the signal declaration for the assigned binders
534   ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
535   ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
536   -- Setup the VHDL Block
537         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
538         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
539         } ;
540   -- Return the block statement coressponding to the TFVec literal
541   ; return $ [AST.CSBSm block]
542   }
543   where
544     genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
545     -- For now we only translate applications
546     genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
547       let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
548       let valargs = get_val_args (Var.varType f) args
549       apps <- genApplication (Left bndr) f (map Left valargs)
550       return (Just bndr, apps)
551     genBinderAssign _ = return (Nothing,[])
552     genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
553     genResAssign app@(CoreSyn.App _ letexpr) = do
554       case letexpr of
555         (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
556           letapps <- mapM genBinderAssign letbndrs
557           let bndrs = Maybe.catMaybes (map fst letapps)
558           let app = (map snd letapps)
559           (vars, apps) <- genResAssign letres
560           return ((bndrs ++ vars),((concat app) ++ apps))
561         otherwise -> return ([],[])
562     genResAssign _ = return ([],[])
563
564 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
565   ; let { elems = reduceCoreListToHsList app
566   -- Make signal names for all the binders
567         ; binders = map (\expr -> case expr of 
568                           (CoreSyn.Var b) -> b
569                           otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: " 
570                             ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
571         } ;
572   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
573   -- Assign all the signals to the resulting vector
574   ; let { vecsigns = mkAggregateSignal sigs
575         ; vecassign = mkUncondAssign (Left res) vecsigns
576   -- Setup the VHDL Block
577         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
578         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
579         } ;
580   -- Return the block statement coressponding to the TFVec literal
581   ; return $ [AST.CSBSm block]
582   }
583   
584 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
585
586 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
587 -}
588 -- | Generate a generate statement for the builtin function "map"
589 genMap :: BuiltinBuilder
590 genMap (Left res) f [(Left mapped_f, _), (Left (CoreSyn.Var arg), _)] = do {
591   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
592   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
593   -- we must index it (which we couldn't if it was a VHDL Expr, since only
594   -- VHDLNames can be indexed).
595   -- Setup the generate scheme
596   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
597   ; let res_type = (tfvec_elem . Var.varType) res
598           -- TODO: Use something better than varToString
599   ; let { label       = mkVHDLExtId ("mapVector" ++ (varToUniqString res))
600         ; n_id        = mkVHDLBasicId "n"
601         ; n_expr      = idToVHDLExpr n_id
602         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
603         ; genScheme   = AST.ForGn n_id range
604           -- Create the content of the generate statement: Applying the mapped_f to
605           -- each of the elements in arg, storing to each element in res
606         ; resname     = mkIndexedName (varToVHDLName res) n_expr
607         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
608         ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
609         ; valargs     = get_val_args (Var.varType real_f) already_mapped_args
610         } ;   
611   ; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, (tfvec_elem . Var.varType) arg)])
612     -- Return the generate statement
613   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
614   }
615
616 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
617     
618 genZipWith :: BuiltinBuilder
619 genZipWith (Left res) f args@[(Left zipped_f, _), (Left (CoreSyn.Var arg1), _), (Left (CoreSyn.Var arg2), _)] = do {
620   -- Setup the generate scheme
621   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
622   ; let res_type = (tfvec_elem . Var.varType) res
623           -- TODO: Use something better than varToString
624   ; let { label       = mkVHDLExtId ("zipWithVector" ++ (varToUniqString res))
625         ; n_id        = mkVHDLBasicId "n"
626         ; n_expr      = idToVHDLExpr n_id
627         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
628         ; genScheme   = AST.ForGn n_id range
629           -- Create the content of the generate statement: Applying the zipped_f to
630           -- each of the elements in arg1 and arg2, storing to each element in res
631         ; resname     = mkIndexedName (varToVHDLName res) n_expr
632         ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs zipped_f
633         ; valargs     = get_val_args (Var.varType real_f) already_mapped_args
634         ; argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
635         ; argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
636         } ;
637   ; (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr1, (tfvec_elem . Var.varType) arg1), (Right argexpr2, (tfvec_elem . Var.varType) arg2)])
638     -- Return the generate functions
639   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
640   }
641
642 genFoldl :: BuiltinBuilder
643 genFoldl = genFold True
644
645 genFoldr :: BuiltinBuilder
646 genFoldr = genFold False
647
648 genFold :: Bool -> BuiltinBuilder
649 genFold left res f args@[folded_f, start, (vec, vecType)] = do
650   len <- MonadState.lift tsType $ tfp_to_int (tfvec_len_ty vecType)
651   genFold' len left res f args
652
653 genFold' :: Int -> Bool -> BuiltinBuilder
654 -- Special case for an empty input vector, just assign start to res
655 genFold' len left (Left res) _ [_, (start, _), vec] | len == 0 = do
656   [arg] <- argsToVHDLExprs [start]
657   return ([mkUncondAssign (Left res) arg], [])
658     
659 genFold' len left (Left res) f [(Left folded_f,_), (start,startType), (vec,vecType)] = do
660   [vecExpr] <- argsToVHDLExprs [vec]
661   -- The vector length
662   --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
663   -- An expression for len-1
664   let len_min_expr = (AST.PrimLit $ show (len-1))
665   -- evec is (TFVec n), so it still needs an element type
666   let (nvec, _) = Type.splitAppTy vecType
667   -- Put the type of the start value in nvec, this will be the type of our
668   -- temporary vector
669   let tmp_ty = Type.mkAppTy nvec startType
670   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
671   -- TODO: Handle Nothing
672   Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
673   -- Setup the generate scheme
674   let gen_label = mkVHDLExtId ("foldlVector" ++ (show vecExpr))
675   let block_label = mkVHDLExtId ("foldlVector" ++ (varToUniqString res))
676   let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
677                   else AST.DownRange len_min_expr (AST.PrimLit "0")
678   let gen_scheme   = AST.ForGn n_id gen_range
679   -- Make the intermediate vector
680   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
681   -- Create the generate statement
682   cells' <- sequence [genFirstCell, genOtherCell]
683   let (cells, useds) = unzip cells'
684   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
685   -- Assign tmp[len-1] or tmp[0] to res
686   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
687                     (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
688                     (mkIndexedName tmp_name (AST.PrimLit "0")))      
689   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
690   return ([AST.CSBSm block], concat useds)
691   where
692     -- An id for the counter
693     n_id = mkVHDLBasicId "n"
694     n_cur = idToVHDLExpr n_id
695     -- An expression for previous n
696     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
697                      else (n_cur AST.:+: (AST.PrimLit "1"))
698     -- An id for the tmp result vector
699     tmp_id = mkVHDLBasicId "tmp"
700     tmp_name = AST.NSimple tmp_id
701     -- Generate parts of the fold
702     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
703     genFirstCell = do
704       [AST.PrimName vecName, argexpr1] <- argsToVHDLExprs [vec,start]
705       let res_type = (tfvec_elem . Var.varType) res
706       len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
707       let cond_label = mkVHDLExtId "firstcell"
708       -- if n == 0 or n == len-1
709       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
710                                                   else (AST.PrimLit $ show (len-1)))
711       -- Output to tmp[current n]
712       let resname = mkIndexedName tmp_name n_cur
713       -- Input from start
714       -- argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
715       -- Input from vec[current n]
716       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
717       let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
718       let valargs     = get_val_args (Var.varType real_f) already_mapped_args
719       (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ ( if left then
720                                                                   [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
721                                                                 else
722                                                                   [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
723                                                               ))
724       -- Return the conditional generate part
725       return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
726
727     genOtherCell = do
728       [AST.PrimName vecName] <- argsToVHDLExprs [vec]
729       let res_type = (tfvec_elem . Var.varType) res
730       len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecType
731       let cond_label = mkVHDLExtId "othercell"
732       -- if n > 0 or n < len-1
733       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
734                                                    else (AST.PrimLit $ show (len-1)))
735       -- Output to tmp[current n]
736       let resname = mkIndexedName tmp_name n_cur
737       -- Input from tmp[previous n]
738       let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
739       -- Input from vec[current n]
740       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName vecName n_cur
741       let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs folded_f
742       let valargs     = get_val_args (Var.varType real_f) already_mapped_args
743       (app_concsms, used) <- genApplication (Right resname,res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++  ( if left then
744                                                                   [(Right argexpr1, startType), (Right argexpr2, tfvec_elem vecType)]
745                                                                 else
746                                                                   [(Right argexpr2, tfvec_elem vecType), (Right argexpr1, startType)]
747                                                               ))
748       -- Return the conditional generate part
749       return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
750
751 -- | Generate a generate statement for the builtin function "zip"
752 genZip :: BuiltinBuilder
753 genZip = genNoInsts genZip'
754 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
755 genZip' (Left res) f args@[(arg1,_), (arg2,_)] = do {
756     -- Setup the generate scheme
757   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
758   ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genZip: Invalid result type" (tfvec_elem (Var.varType res))
759   ; [AST.PrimName argName1, AST.PrimName argName2] <- argsToVHDLExprs [arg1,arg2] 
760           -- TODO: Use something better than varToString
761   ; let { label           = mkVHDLExtId ("zipVector" ++ (varToUniqString res))
762         ; n_id            = mkVHDLBasicId "n"
763         ; n_expr          = idToVHDLExpr n_id
764         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
765         ; genScheme       = AST.ForGn n_id range
766         ; resname'        = mkIndexedName (varToVHDLName res) n_expr
767         ; argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName argName1 n_expr
768         ; argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName argName2 n_expr
769         ; labels          = getFieldLabels res_htype 0
770         }
771   ; let { resnameA    = mkSelectedName resname' (labels!!0)
772         ; resnameB    = mkSelectedName resname' (labels!!1)
773         ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
774         ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
775         } ;
776     -- Return the generate functions
777   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
778   }
779   
780 -- | Generate a generate statement for the builtin function "fst"
781 genFst :: BuiltinBuilder
782 genFst = genNoInsts genFst'
783 genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
784 genFst' res f args@[(arg,argType)] = do {
785   ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
786   ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] 
787   ; let { 
788         ; labels      = getFieldLabels arg_htype 0
789         ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
790         ; assign      = mkUncondAssign res argexprA
791         } ;
792     -- Return the generate functions
793   ; return [assign]
794   }
795   
796 -- | Generate a generate statement for the builtin function "snd"
797 genSnd :: BuiltinBuilder
798 genSnd = genNoInsts genSnd'
799 genSnd' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
800 genSnd' (Left res) f args@[(arg,argType)] = do {
801   ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSnd: Invalid argument type" argType
802   ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] 
803   ; let { 
804         ; labels      = getFieldLabels arg_htype 0
805         ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!1)
806         ; assign      = mkUncondAssign (Left res) argexprB
807         } ;
808     -- Return the generate functions
809   ; return [assign]
810   }
811     
812 -- | Generate a generate statement for the builtin function "unzip"
813 genUnzip :: BuiltinBuilder
814 genUnzip = genNoInsts genUnzip'
815 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
816 genUnzip' (Left res) f args@[(arg,argType)] = do
817   let error_msg = "\nGenerate.genUnzip: Cannot generate unzip call: " ++ pprString res ++ " = " ++ pprString f ++ " " ++ show arg
818   htype <- MonadState.lift tsType $ mkHType error_msg argType
819   -- Prepare a unconditional assignment, for the case when either part
820   -- of the unzip is a state variable, which will disappear in the
821   -- resulting VHDL, making the the unzip no longer required.
822   case htype of
823     -- A normal vector containing two-tuples
824     VecType _ (AggrType _ _ [_, _]) -> do {
825         -- Setup the generate scheme
826       ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
827       ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid argument type" argType
828       ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genUnzip: Invalid result type" (Var.varType res)
829       ; [AST.PrimName arg'] <- argsToVHDLExprs [arg]
830         -- TODO: Use something better than varToString
831       ; let { label           = mkVHDLExtId ("unzipVector" ++ (varToUniqString res))
832             ; n_id            = mkVHDLBasicId "n"
833             ; n_expr          = idToVHDLExpr n_id
834             ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
835             ; genScheme       = AST.ForGn n_id range
836             ; resname'        = varToVHDLName res
837             ; argexpr'        = mkIndexedName arg' n_expr
838             ; reslabels       = getFieldLabels res_htype 0
839             ; arglabels       = getFieldLabels arg_htype 0
840             } ;
841       ; let { resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
842             ; resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
843             ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
844             ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
845             ; resA_assign = mkUncondAssign (Right resnameA) argexprA
846             ; resB_assign = mkUncondAssign (Right resnameB) argexprB
847             } ;
848         -- Return the generate functions
849       ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
850       }
851     -- Both elements of the tuple were state, so they've disappeared. No
852     -- need to do anything
853     VecType _ (AggrType _ _ []) -> return []
854     -- A vector containing aggregates with more than two elements?
855     VecType _ (AggrType _ _ _) -> error $ "Unzipping a value that is not a vector of two-tuples? Value: " ++ show arg ++ "\nType: " ++ pprString argType
856     -- One of the elements of the tuple was state, so there won't be a
857     -- tuple (record) in the VHDL output. We can just do a plain
858     -- assignment, then.
859     VecType _ _ -> do
860       [argexpr] <- argsToVHDLExprs [arg]
861       return [mkUncondAssign (Left res) argexpr]
862     _ -> error $ "Unzipping a value that is not a vector? Value: " ++ show arg ++ "\nType: " ++ pprString argType ++ "\nhtype: " ++ show htype
863
864 genCopy :: BuiltinBuilder 
865 genCopy = genNoInsts genCopy'
866 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
867 genCopy' (Left res) f [(arg,argType)] = do {
868   ; [arg'] <- argsToVHDLExprs [arg]
869   ; let { resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others) arg']
870         ; out_assign = mkUncondAssign (Left res) resExpr
871         }
872   ; return [out_assign]
873   }
874     
875 genConcat :: BuiltinBuilder
876 genConcat = genNoInsts genConcat'
877 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
878 genConcat' (Left res) f args@[(arg,argType)] = do {
879     -- Setup the generate scheme
880   ; len1 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty argType
881   ; let (_, nvec) = Type.splitAppTy argType
882   ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
883   ; [AST.PrimName argName] <- argsToVHDLExprs [arg]
884           -- TODO: Use something better than varToString
885   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToUniqString res))
886         ; n_id        = mkVHDLBasicId "n"
887         ; n_expr      = idToVHDLExpr n_id
888         ; fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
889         ; genScheme   = AST.ForGn n_id range
890           -- Create the content of the generate statement: Applying the mapped_f to
891           -- each of the elements in arg, storing to each element in res
892         ; toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
893         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
894         ; resname     = vecSlice fromRange toRange
895         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName argName n_expr
896         ; out_assign  = mkUncondAssign (Right resname) argexpr
897         } ;
898     -- Return the generate statement
899   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
900   }
901   where
902     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
903                             (AST.ToRange init last))
904
905 genIteraten :: BuiltinBuilder
906 genIteraten dst f args = genIterate dst f (tail args)
907
908 genIterate :: BuiltinBuilder
909 genIterate = genIterateOrGenerate True
910
911 genGeneraten :: BuiltinBuilder
912 genGeneraten dst f args = genGenerate dst f (tail args)
913
914 genGenerate :: BuiltinBuilder
915 genGenerate = genIterateOrGenerate False
916
917 genIterateOrGenerate :: Bool -> BuiltinBuilder
918 genIterateOrGenerate iter (Left res) f args = do
919   len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
920   genIterateOrGenerate' len iter (Left res) f args
921
922 genIterateOrGenerate' :: Int -> Bool -> BuiltinBuilder
923 -- Special case for an empty input vector, just assign start to res
924 genIterateOrGenerate' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
925
926 genIterateOrGenerate' len iter (Left res) f [(Left app_f,_), (start,startType)] = do
927   -- The vector length
928   -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
929   -- An expression for len-1
930   let len_min_expr = (AST.PrimLit $ show (len-1))
931   -- -- evec is (TFVec n), so it still needs an element type
932   -- let (nvec, _) = splitAppTy (Var.varType vec)
933   -- -- Put the type of the start value in nvec, this will be the type of our
934   -- -- temporary vector
935   let tmp_ty = Var.varType res
936   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty 
937   -- TODO: Handle Nothing
938   Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdlTy error_msg tmp_ty
939   -- Setup the generate scheme
940   [startExpr] <- argsToVHDLExprs [start]
941   let gen_label = mkVHDLExtId ("iterateVector" ++ (show startExpr))
942   let block_label = mkVHDLExtId ("iterateVector" ++ (varToUniqString res))
943   let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
944   let gen_scheme   = AST.ForGn n_id gen_range
945   -- Make the intermediate vector
946   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
947   -- Create the generate statement
948   cells' <- sequence [genFirstCell, genOtherCell]
949   let (cells, useds) = unzip cells'
950   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
951   -- Assign tmp[len-1] or tmp[0] to res
952   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name    
953   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
954   return ([AST.CSBSm block], concat useds)
955   where
956     -- An id for the counter
957     n_id = mkVHDLBasicId "n"
958     n_cur = idToVHDLExpr n_id
959     -- An expression for previous n
960     n_prev = n_cur AST.:-: (AST.PrimLit "1")
961     -- An id for the tmp result vector
962     tmp_id = mkVHDLBasicId "tmp"
963     tmp_name = AST.NSimple tmp_id
964     -- Generate parts of the fold
965     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
966     genFirstCell = do
967       let res_type = (tfvec_elem . Var.varType) res
968       let cond_label = mkVHDLExtId "firstcell"
969       -- if n == 0 or n == len-1
970       let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
971       -- Output to tmp[current n]
972       let resname = mkIndexedName tmp_name n_cur
973       -- Input from start
974       [argexpr] <- argsToVHDLExprs [start]
975       let startassign = mkUncondAssign (Right resname) argexpr
976       let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
977       let valargs     = get_val_args (Var.varType real_f) already_mapped_args
978       (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, startType)])
979       -- Return the conditional generate part
980       let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then 
981                                                           [startassign]
982                                                          else 
983                                                           app_concsms
984                                                         )
985       return (gensm, used)
986
987     genOtherCell = do
988       let res_type = (tfvec_elem . Var.varType) res
989       let cond_label = mkVHDLExtId "othercell"
990       -- if n > 0 or n < len-1
991       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
992       -- Output to tmp[current n]
993       let resname = mkIndexedName tmp_name n_cur
994       -- Input from tmp[previous n]
995       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
996       let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs app_f
997       let valargs     = get_val_args (Var.varType real_f) already_mapped_args
998       (app_concsms, used) <- genApplication (Right resname, res_type) real_f ((zip (map Left valargs) (map CoreUtils.exprType valargs)) ++ [(Right argexpr, res_type)])
999       -- Return the conditional generate part
1000       return (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
1001
1002 genBlockRAM :: BuiltinBuilder
1003 genBlockRAM = genNoInsts $ genExprArgs genBlockRAM'
1004
1005 genBlockRAM' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(AST.Expr,Type.Type)] -> TranslatorSession [AST.ConcSm]
1006 genBlockRAM' (Left res) f args@[data_in,rdaddr,wraddr,wrenable] = do
1007   -- Get the ram type
1008   let (tup,data_out) = Type.splitAppTy (Var.varType res)
1009   let (tup',ramvec) = Type.splitAppTy tup
1010   let Just realram = Type.coreView ramvec
1011   let Just (tycon, types) = Type.splitTyConApp_maybe realram
1012   Just ram_vhdl_ty <- MonadState.lift tsType $ vhdlTy "wtf" (head types)
1013   -- Make the intermediate vector
1014   let ram_dec = AST.BDISD $ AST.SigDec ram_id ram_vhdl_ty Nothing
1015   -- Get the data_out name
1016   -- reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
1017   let resname = varToVHDLName res
1018   -- let resname = mkSelectedName resname' (reslabels!!0)
1019   let rdaddr_int = genExprFCall (mkVHDLBasicId toIntegerId) $ fst rdaddr
1020   let argexpr = vhdlNameToVHDLExpr $ mkIndexedName (AST.NSimple ram_id) rdaddr_int
1021   let assign = mkUncondAssign (Right resname) argexpr
1022   let block_label = mkVHDLExtId ("blockRAM" ++ (varToUniqString res))
1023   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [ram_dec] [assign, mkUpdateProcSm]
1024   return [AST.CSBSm block]
1025   where
1026     ram_id = mkVHDLBasicId "ram"
1027     mkUpdateProcSm :: AST.ConcSm
1028     mkUpdateProcSm = AST.CSPSm $ AST.ProcSm proclabel [clockId] [statement]
1029       where
1030         proclabel   = mkVHDLBasicId "updateRAM"
1031         rising_edge = mkVHDLBasicId "rising_edge"
1032         wraddr_int  = genExprFCall (mkVHDLBasicId toIntegerId) $ fst wraddr
1033         ramloc      = mkIndexedName (AST.NSimple ram_id) wraddr_int
1034         wform       = AST.Wform [AST.WformElem (fst data_in) Nothing]
1035         ramassign      = AST.SigAssign ramloc wform
1036         rising_edge_clk = genExprFCall rising_edge (AST.PrimName $ AST.NSimple clockId)
1037         statement   = AST.IfSm (AST.And rising_edge_clk $ fst wrenable) [ramassign] [] Nothing
1038         
1039 genSplit :: BuiltinBuilder
1040 genSplit = genNoInsts genSplit'
1041
1042 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
1043 genSplit' (Left res) f args@[(vecIn,vecInType)] = do {
1044   ; len <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty vecInType
1045   ; res_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genSplit': Invalid result type" (Var.varType res)
1046   ; [argExpr] <- argsToVHDLExprs [vecIn]
1047   ; let { 
1048         ; labels    = getFieldLabels res_htype 0
1049         ; block_label = mkVHDLExtId ("split" ++ show argExpr)
1050         ; halflen   = round ((fromIntegral len) / 2)
1051         ; rangeL    = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
1052         ; rangeR    = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
1053         ; resname   = varToVHDLName res
1054         ; resnameL  = mkSelectedName resname (labels!!0)
1055         ; resnameR  = mkSelectedName resname (labels!!1)
1056         ; argexprL  = vhdlNameToVHDLExpr rangeL
1057         ; argexprR  = vhdlNameToVHDLExpr rangeR
1058         ; out_assignL = mkUncondAssign (Right resnameL) argexprL
1059         ; out_assignR = mkUncondAssign (Right resnameR) argexprR
1060         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
1061         }
1062   ; return [AST.CSBSm block]
1063   }
1064   where
1065     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res) 
1066                             (AST.ToRange init last))
1067                             
1068 genSll :: BuiltinBuilder
1069 genSll = genNoInsts $ genExprArgs $ genExprRes genSll'
1070 genSll' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1071 genSll' res f [(arg1,_),(arg2,_)] = do {
1072   ; return $ (AST.Sll arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1073   }
1074
1075 genSra :: BuiltinBuilder
1076 genSra = genNoInsts $ genExprArgs $ genExprRes genSra'
1077 genSra' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [(AST.Expr, Type.Type)] -> TranslatorSession AST.Expr
1078 genSra' res f [(arg1,_),(arg2,_)] = do {
1079   ; return $ (AST.Sra arg1 (genExprFCall (mkVHDLBasicId toIntegerId) arg2))
1080   }
1081
1082 -----------------------------------------------------------------------------
1083 -- Function to generate VHDL for applications
1084 -----------------------------------------------------------------------------
1085 genApplication ::
1086   (Either CoreSyn.CoreBndr AST.VHDLName, Type.Type) -- ^ Where to store the result?
1087   -> CoreSyn.CoreBndr -- ^ The function to apply
1088   -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The arguments to apply
1089   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
1090   -- ^ The corresponding VHDL concurrent statements and entities
1091   --   instantiated.
1092 genApplication (dst, dsttype) f args = do
1093   nonemptydst <- case dst of
1094     Left bndr -> hasNonEmptyType bndr 
1095     Right _ -> return True
1096   if nonemptydst
1097     then
1098       if Var.isGlobalId f then
1099         case Var.idDetails f of
1100           IdInfo.DataConWorkId dc -> do -- case dst of
1101             -- It's a datacon. Create a record from its arguments.
1102             --Left bndr -> do
1103               -- We have the bndr, so we can get at the type
1104               htype_either <- MonadState.lift tsType $ mkHTypeEither dsttype
1105               let argsNoState = filter (\x -> not (either hasStateType (\x -> False) x)) (map fst args)
1106               let dcs = datacons_for dsttype
1107               case (dcs, argsNoState) of
1108                 -- This is a type with a single datacon and a single
1109                 -- argument, so no record is created (the type of the
1110                 -- binder becomes the type of the single argument).
1111                 ([_], [arg]) -> do
1112                   [arg'] <- argsToVHDLExprs [arg]
1113                   return ([mkUncondAssign dst arg'], [])
1114                 -- In all other cases, a record type is created.
1115                 _ -> case htype_either of
1116                   Right htype@(AggrType _ etype _) -> do
1117                     let dc_i = datacon_index dsttype dc
1118                     let labels = getFieldLabels htype dc_i
1119                     arg_exprs <- argsToVHDLExprs argsNoState
1120                     let (final_labels, final_exprs) = case getConstructorFieldLabel htype of
1121                           -- Only a single constructor
1122                           Nothing -> 
1123                             (labels, arg_exprs)
1124                           -- Multiple constructors, so assign the
1125                           -- constructor used to the constructor field as
1126                           -- well.
1127                           Just dc_label ->
1128                             let { dc_index = getConstructorIndex (snd $ Maybe.fromJust etype) (varToString f)
1129                                 ; dc_expr = AST.PrimLit $ show dc_index 
1130                                 } in (dc_label:labels, dc_expr:arg_exprs)
1131                     return (zipWith mkassign final_labels final_exprs, [])
1132                     where
1133                       mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1134                       mkassign label arg =
1135                         let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1136                         mkUncondAssign (Right sel_name) arg
1137                   -- Enumeration types have no arguments and are just
1138                   -- simple assignments
1139                   Right (EnumType _ _) ->
1140                     simple_assign
1141                   -- These builtin types are also enumeration types
1142                   Right (BuiltinType tyname) | tyname `elem` ["Bit", "Bool"] ->
1143                     simple_assign
1144                   Right _ -> error $ "Datacon application does not result in a aggregate type? datacon: " ++ pprString f ++ " Args: " ++ show args
1145                   Left _ -> error $ "Unrepresentable result type in datacon application?  datacon: " ++ pprString f ++ " Args: " ++ show args
1146                   where
1147                     -- Simple uncoditional assignment, for (built-in)
1148                     -- enumeration types
1149                     simple_assign = do
1150                       expr <- MonadState.lift tsType $ dataconToVHDLExpr dc
1151                       return ([mkUncondAssign dst expr], [])
1152             -- 
1153             -- Right _ -> do
1154             --   let dcs = datacons_for dsttype
1155             --   error $ "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder" ++ show dcs
1156           IdInfo.DataConWrapId dc -> case dst of
1157             -- It's a datacon. Create a record from its arguments.
1158             Left bndr ->
1159               case (Map.lookup (varToString f) globalNameTable) of
1160                Just (arg_count, builder) ->
1161                 if length args == arg_count then
1162                   builder dst f args
1163                 else
1164                   error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1165                Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1166             Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1167           IdInfo.VanillaId ->
1168             -- It's a global value imported from elsewhere. These can be builtin
1169             -- functions. Look up the function name in the name table and execute
1170             -- the associated builder if there is any and the argument count matches
1171             -- (this should always be the case if it typechecks, but just to be
1172             -- sure...).
1173             case (Map.lookup (varToString f) globalNameTable) of
1174               Just (arg_count, builder) ->
1175                 if length args == arg_count then
1176                   builder dst f args
1177                 else
1178                   error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1179               Nothing -> do
1180                 top <- isTopLevelBinder f
1181                 if top then
1182                   do
1183                     -- Local binder that references a top level binding.  Generate a
1184                     -- component instantiation.
1185                     signature <- getEntity f
1186                     args' <- argsToVHDLExprs (map fst args)
1187                     let entity_id = ent_id signature
1188                     -- TODO: Using show here isn't really pretty, but we'll need some
1189                     -- unique-ish value...
1190                     let label = "comp_ins_" ++ (either show prettyShow) dst
1191                     let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1192                     return ([mkComponentInst label entity_id portmaps], [f])
1193                   else
1194                     -- Not a top level binder, so this must be a local variable reference.
1195                     -- It should have a representable type (and thus, no arguments) and a
1196                     -- signal should be generated for it. Just generate an unconditional
1197                     -- assignment here.
1198                     -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1199                     -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1200                     --                   return $ ([mkUncondAssign dst f'], [])
1201                   do errtype <- case dst of 
1202                         Left bndr -> do 
1203                           htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1204                           return (show htype)
1205                         Right vhd -> return $ show vhd
1206                      error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype) 
1207           IdInfo.ClassOpId cls ->
1208             -- FIXME: Not looking for what instance this class op is called for
1209             -- Is quite stupid of course.
1210             case (Map.lookup (varToString f) globalNameTable) of
1211               Just (arg_count, builder) ->
1212                 if length args == arg_count then
1213                   builder dst f args
1214                 else
1215                   error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1216               Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1217           details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1218         else do
1219           top <- isTopLevelBinder f
1220           if top then
1221             do
1222                -- Local binder that references a top level binding.  Generate a
1223                -- component instantiation.
1224                signature <- getEntity f
1225                args' <- argsToVHDLExprs (map fst args)
1226                let entity_id = ent_id signature
1227                -- TODO: Using show here isn't really pretty, but we'll need some
1228                -- unique-ish value...
1229                let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1230                let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1231                return ([mkComponentInst label entity_id portmaps], [f])
1232             else
1233               -- Not a top level binder, so this must be a local variable reference.
1234               -- It should have a representable type (and thus, no arguments) and a
1235               -- signal should be generated for it. Just generate an unconditional
1236               -- assignment here.
1237             do f' <- MonadState.lift tsType $ varToVHDLExpr f
1238                return ([mkUncondAssign dst f'], [])
1239     else -- Destination has empty type, don't generate anything
1240       return ([], [])
1241 -----------------------------------------------------------------------------
1242 -- Functions to generate functions dealing with vectors.
1243 -----------------------------------------------------------------------------
1244
1245 -- Returns the VHDLId of the vector function with the given name for the given
1246 -- element type. Generates -- this function if needed.
1247 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1248 vectorFunId el_ty fname = do
1249   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1250   -- TODO: Handle the Nothing case?
1251   elemTM_maybe <- vhdlTy error_msg el_ty
1252   let elemTM = Maybe.fromMaybe
1253                  (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1254                  elemTM_maybe
1255   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1256   -- the VHDLState or something.
1257   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1258   typefuns <- MonadState.get tsTypeFuns
1259   el_htype <- mkHType error_msg el_ty
1260   case Map.lookup (UVecType el_htype, fname) typefuns of
1261     -- Function already generated, just return it
1262     Just (id, _) -> return id
1263     -- Function not generated yet, generate it
1264     Nothing -> do
1265       let functions = genUnconsVectorFuns elemTM vectorTM
1266       case lookup fname functions of
1267         Just body -> do
1268           MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1269           mapM_ (vectorFunId el_ty) (snd body)
1270           return function_id
1271         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1272   where
1273     function_id = mkVHDLExtId fname
1274
1275 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1276                     -> AST.TypeMark -- ^ type of the vector
1277                     -> [(String, (AST.SubProgBody, [String]))]
1278 genUnconsVectorFuns elemTM vectorTM  = 
1279   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
1280   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1281   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
1282   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
1283   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1284   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
1285   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
1286   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1287   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr],[]))
1288   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1289   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
1290   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
1291   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))  
1292   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1293   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1294   , (shiftIntoLId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1295   , (shiftIntoRId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1296   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1297   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1298   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1299   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1300   ]
1301   where 
1302     ixPar   = AST.unsafeVHDLBasicId "ix"
1303     vecPar  = AST.unsafeVHDLBasicId "vec"
1304     vec1Par = AST.unsafeVHDLBasicId "vec1"
1305     vec2Par = AST.unsafeVHDLBasicId "vec2"
1306     nPar    = AST.unsafeVHDLBasicId "n"
1307     leftPar = AST.unsafeVHDLBasicId "nLeft"
1308     rightPar = AST.unsafeVHDLBasicId "nRight"
1309     iId     = AST.unsafeVHDLBasicId "i"
1310     iPar    = iId
1311     aPar    = AST.unsafeVHDLBasicId "a"
1312     fPar = AST.unsafeVHDLBasicId "f"
1313     sPar = AST.unsafeVHDLBasicId "s"
1314     resId   = AST.unsafeVHDLBasicId "res"    
1315     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1316                                AST.IfaceVarDec ixPar  unsignedTM] elemTM
1317     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed 
1318               (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1319     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
1320                                           , AST.IfaceVarDec iPar   unsignedTM
1321                                           , AST.IfaceVarDec aPar   elemTM
1322                                           ] vectorTM 
1323        -- variable res : fsvec_x (0 to vec'length-1);
1324     replaceVar =
1325          AST.VarDec resId 
1326                 (AST.SubtypeIn vectorTM
1327                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1328                    [AST.ToRange (AST.PrimLit "0")
1329                             (AST.PrimName (AST.NAttribute $ 
1330                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1331                                 (AST.PrimLit "1"))   ]))
1332                 Nothing
1333        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1334     replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1335     replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1336     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1337     vecSlice init last =  AST.PrimName (AST.NSlice 
1338                                         (AST.SliceName 
1339                                               (AST.NSimple vecPar) 
1340                                               (AST.ToRange init last)))
1341     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1342        -- return vec(vec'length-1);
1343     lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName 
1344                     (AST.NSimple vecPar) 
1345                     [AST.PrimName (AST.NAttribute $ 
1346                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
1347                                                              AST.:-: AST.PrimLit "1"])))
1348     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
1349        -- variable res : fsvec_x (0 to vec'length-2);
1350     initVar = 
1351          AST.VarDec resId 
1352                 (AST.SubtypeIn vectorTM
1353                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1354                    [AST.ToRange (AST.PrimLit "0")
1355                             (AST.PrimName (AST.NAttribute $ 
1356                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1357                                 (AST.PrimLit "2"))   ]))
1358                 Nothing
1359        -- resAST.:= vec(0 to vec'length-2)
1360     initExpr = AST.NSimple resId AST.:= (vecSlice 
1361                                (AST.PrimLit "0") 
1362                                (AST.PrimName (AST.NAttribute $ 
1363                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
1364                                                              AST.:-: AST.PrimLit "2"))
1365     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1366     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
1367                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
1368     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1369                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1370                         []
1371                         (Just $ AST.Else [minimumExprRet])
1372       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1373     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
1374                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1375        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1376     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))  
1377                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1378                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $ 
1379                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1380     takeVar = 
1381          AST.VarDec resId 
1382                 (AST.SubtypeIn vectorTM
1383                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1384                    [AST.ToRange (AST.PrimLit "0")
1385                                (minLength AST.:-:
1386                                 (AST.PrimLit "1"))   ]))
1387                 Nothing
1388        -- res AST.:= vec(0 to n-1)
1389     takeExpr = AST.NSimple resId AST.:= 
1390                     (vecSlice (AST.PrimLit "0") 
1391                               (minLength AST.:-: AST.PrimLit "1"))
1392     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1393     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
1394                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM 
1395        -- variable res : fsvec_x (0 to vec'length-n-1);
1396     dropVar = 
1397          AST.VarDec resId 
1398                 (AST.SubtypeIn vectorTM
1399                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1400                    [AST.ToRange (AST.PrimLit "0")
1401                             (AST.PrimName (AST.NAttribute $ 
1402                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1403                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1404                Nothing
1405        -- res AST.:= vec(n to vec'length-1)
1406     dropExpr = AST.NSimple resId AST.:= (vecSlice 
1407                                (AST.PrimName $ AST.NSimple nPar) 
1408                                (AST.PrimName (AST.NAttribute $ 
1409                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) 
1410                                                              AST.:-: AST.PrimLit "1"))
1411     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1412     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
1413                                        AST.IfaceVarDec vecPar vectorTM] vectorTM 
1414     -- variable res : fsvec_x (0 to vec'length);
1415     plusgtVar = 
1416       AST.VarDec resId 
1417              (AST.SubtypeIn vectorTM
1418                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1419                 [AST.ToRange (AST.PrimLit "0")
1420                         (AST.PrimName (AST.NAttribute $ 
1421                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1422              Nothing
1423     plusgtExpr = AST.NSimple resId AST.:= 
1424                    ((AST.PrimName $ AST.NSimple aPar) AST.:&: 
1425                     (AST.PrimName $ AST.NSimple vecPar))
1426     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1427     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1428     emptyVar = 
1429           AST.VarDec resId
1430             (AST.SubtypeIn vectorTM
1431               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1432                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1433              Nothing
1434     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1435     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ] 
1436                                          vectorTM
1437     -- variable res : fsvec_x (0 to 0) := (others => a);
1438     singletonVar = 
1439       AST.VarDec resId 
1440              (AST.SubtypeIn vectorTM
1441                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1442                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1443              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
1444                                           (AST.PrimName $ AST.NSimple aPar)])
1445     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1446     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1447                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM 
1448     -- variable res : fsvec_x (0 to n-1) := (others => a);
1449     copynVar = 
1450       AST.VarDec resId 
1451              (AST.SubtypeIn vectorTM
1452                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1453                 [AST.ToRange (AST.PrimLit "0")
1454                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1455                              (AST.PrimLit "1"))   ]))
1456              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others) 
1457                                           (AST.PrimName $ AST.NSimple aPar)])
1458     -- return res
1459     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1460     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1461                                AST.IfaceVarDec sPar   naturalTM,
1462                                AST.IfaceVarDec nPar   naturalTM,
1463                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1464     -- variable res : fsvec_x (0 to n-1);
1465     selVar = 
1466       AST.VarDec resId 
1467                 (AST.SubtypeIn vectorTM
1468                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1469                     [AST.ToRange (AST.PrimLit "0")
1470                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1471                       (AST.PrimLit "1"))   ])
1472                 )
1473                 Nothing
1474     -- for i res'range loop
1475     --   res(i) := vec(f+i*s);
1476     -- end loop;
1477     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1478     -- res(i) := vec(f+i*s);
1479     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+: 
1480                                 (AST.PrimName (AST.NSimple iId) AST.:*: 
1481                                   AST.PrimName (AST.NSimple sPar)) in
1482                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1483                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1484     -- return res;
1485     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1486     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1487                                         AST.IfaceVarDec aPar   elemTM] vectorTM 
1488      -- variable res : fsvec_x (0 to vec'length);
1489     ltplusVar = 
1490       AST.VarDec resId 
1491         (AST.SubtypeIn vectorTM
1492           (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1493             [AST.ToRange (AST.PrimLit "0")
1494               (AST.PrimName (AST.NAttribute $ 
1495                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1496         Nothing
1497     ltplusExpr = AST.NSimple resId AST.:= 
1498                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&: 
1499                       (AST.PrimName $ AST.NSimple aPar))
1500     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1501     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1502                                              AST.IfaceVarDec vec2Par vectorTM] 
1503                                              vectorTM 
1504     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1505     plusplusVar = 
1506       AST.VarDec resId 
1507         (AST.SubtypeIn vectorTM
1508           (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1509             [AST.ToRange (AST.PrimLit "0")
1510               (AST.PrimName (AST.NAttribute $ 
1511                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1512                   AST.PrimName (AST.NAttribute $ 
1513                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1514                   AST.PrimLit "1")]))
1515        Nothing
1516     plusplusExpr = AST.NSimple resId AST.:= 
1517                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&: 
1518                       (AST.PrimName $ AST.NSimple vec2Par))
1519     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1520     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1521     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $ 
1522                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1523     shiftlSpec = AST.Function (mkVHDLExtId shiftIntoLId) [AST.IfaceVarDec vecPar vectorTM,
1524                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM 
1525     -- variable res : fsvec_x (0 to vec'length-1);
1526     shiftlVar = 
1527      AST.VarDec resId 
1528             (AST.SubtypeIn vectorTM
1529               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1530                [AST.ToRange (AST.PrimLit "0")
1531                         (AST.PrimName (AST.NAttribute $ 
1532                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1533                            (AST.PrimLit "1")) ]))
1534             Nothing
1535     -- res := a & init(vec)
1536     shiftlExpr = AST.NSimple resId AST.:=
1537                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1538                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
1539                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1540     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
1541     shiftrSpec = AST.Function (mkVHDLExtId shiftIntoRId) [AST.IfaceVarDec vecPar vectorTM,
1542                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM 
1543     -- variable res : fsvec_x (0 to vec'length-1);
1544     shiftrVar = 
1545      AST.VarDec resId 
1546             (AST.SubtypeIn vectorTM
1547               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1548                [AST.ToRange (AST.PrimLit "0")
1549                         (AST.PrimName (AST.NAttribute $ 
1550                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1551                            (AST.PrimLit "1")) ]))
1552             Nothing
1553     -- res := tail(vec) & a
1554     shiftrExpr = AST.NSimple resId AST.:=
1555                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
1556                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1557                   (AST.PrimName (AST.NSimple aPar)))
1558                 
1559     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)      
1560     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1561     -- return vec'length = 0
1562     nullExpr = AST.ReturnSm (Just $ 
1563                 AST.PrimName (AST.NAttribute $ 
1564                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1565                     AST.PrimLit "0")
1566     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
1567     -- variable res : fsvec_x (0 to vec'length-1);
1568     rotlVar = 
1569      AST.VarDec resId 
1570             (AST.SubtypeIn vectorTM
1571               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1572                [AST.ToRange (AST.PrimLit "0")
1573                         (AST.PrimName (AST.NAttribute $ 
1574                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1575                            (AST.PrimLit "1")) ]))
1576             Nothing
1577     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1578     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
1579                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1580                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1581                         []
1582                         (Just $ AST.Else [rotlExprRet])
1583       where rotlExprRet = 
1584                 AST.NSimple resId AST.:= 
1585                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))  
1586                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1587                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))  
1588                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1589     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)       
1590     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM 
1591     -- variable res : fsvec_x (0 to vec'length-1);
1592     rotrVar = 
1593      AST.VarDec resId 
1594             (AST.SubtypeIn vectorTM
1595               (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1596                [AST.ToRange (AST.PrimLit "0")
1597                         (AST.PrimName (AST.NAttribute $ 
1598                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1599                            (AST.PrimLit "1")) ]))
1600             Nothing
1601     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1602     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))  
1603                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1604                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1605                         []
1606                         (Just $ AST.Else [rotrExprRet])
1607       where rotrExprRet = 
1608                 AST.NSimple resId AST.:= 
1609                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))  
1610                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1611                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))  
1612                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1613     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1614     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1615     reverseVar = 
1616       AST.VarDec resId 
1617              (AST.SubtypeIn vectorTM
1618                (Just $ AST.ConstraintIndex $ AST.IndexConstraint 
1619                 [AST.ToRange (AST.PrimLit "0")
1620                          (AST.PrimName (AST.NAttribute $ 
1621                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1622                             (AST.PrimLit "1")) ]))
1623              Nothing
1624     -- for i in 0 to res'range loop
1625     --   res(vec'length-i-1) := vec(i);
1626     -- end loop;
1627     reverseFor = 
1628        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1629     -- res(vec'length-i-1) := vec(i);
1630     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1631       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) 
1632                            [AST.PrimName $ AST.NSimple iId]))
1633         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar) 
1634                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-: 
1635                         AST.PrimName (AST.NSimple iId) AST.:-: 
1636                         (AST.PrimLit "1") 
1637     -- return res;
1638     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1639
1640     
1641 -----------------------------------------------------------------------------
1642 -- A table of builtin functions
1643 -----------------------------------------------------------------------------
1644
1645 -- A function that generates VHDL for a builtin function
1646 type BuiltinBuilder = 
1647   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1648   -> CoreSyn.CoreBndr -- ^ The function called
1649   -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -- ^ The value arguments passed (excluding type and
1650                     --   dictionary arguments).
1651   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]) 
1652   -- ^ The corresponding VHDL concurrent statements and entities
1653   --   instantiated.
1654
1655 -- A map of a builtin function to VHDL function builder 
1656 type NameTable = Map.Map String (Int, BuiltinBuilder )
1657
1658 -- | The builtin functions we support. Maps a name to an argument count and a
1659 -- builder function. If you add a name to this map, don't forget to add
1660 -- it to VHDL.Constants/builtinIds as well.
1661 globalNameTable :: NameTable
1662 globalNameTable = Map.fromList
1663   [ (exId             , (2, genFCall True          ) )
1664   , (replaceId        , (3, genFCall False          ) )
1665   , (headId           , (1, genFCall True           ) )
1666   , (lastId           , (1, genFCall True           ) )
1667   , (tailId           , (1, genFCall False          ) )
1668   , (initId           , (1, genFCall False          ) )
1669   , (takeId           , (2, genFCall False          ) )
1670   , (dropId           , (2, genFCall False          ) )
1671   , (selId            , (4, genFCall False          ) )
1672   , (plusgtId         , (2, genFCall False          ) )
1673   , (ltplusId         , (2, genFCall False          ) )
1674   , (plusplusId       , (2, genFCall False          ) )
1675   , (mapId            , (2, genMap                  ) )
1676   , (zipWithId        , (3, genZipWith              ) )
1677   , (foldlId          , (3, genFoldl                ) )
1678   , (foldrId          , (3, genFoldr                ) )
1679   , (zipId            , (2, genZip                  ) )
1680   , (unzipId          , (1, genUnzip                ) )
1681   , (shiftIntoLId     , (2, genFCall False          ) )
1682   , (shiftIntoRId     , (2, genFCall False          ) )
1683   , (rotlId           , (1, genFCall False          ) )
1684   , (rotrId           , (1, genFCall False          ) )
1685   , (concatId         , (1, genConcat               ) )
1686   , (reverseId        , (1, genFCall False          ) )
1687   , (iteratenId       , (3, genIteraten             ) )
1688   , (iterateId        , (2, genIterate              ) )
1689   , (generatenId      , (3, genGeneraten            ) )
1690   , (generateId       , (2, genGenerate             ) )
1691   , (emptyId          , (0, genFCall False          ) )
1692   , (singletonId      , (1, genFCall False          ) )
1693   , (copynId          , (2, genFCall False          ) )
1694   , (copyId           , (1, genCopy                 ) )
1695   , (lengthTId        , (1, genFCall False          ) )
1696   , (nullId           , (1, genFCall False          ) )
1697   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1698   , (hwandId          , (2, genOperator2 AST.And    ) )
1699   , (hworId           , (2, genOperator2 AST.Or     ) )
1700   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1701   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
1702   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )
1703   , (ltId             , (2, genOperator2 (AST.:<:)  ) )
1704   , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
1705   , (gtId             , (2, genOperator2 (AST.:>:)  ) )
1706   , (gteqId           , (2, genOperator2 (AST.:>=:) ) )
1707   , (boolOrId         , (2, genOperator2 AST.Or     ) )
1708   , (boolAndId        , (2, genOperator2 AST.And    ) )
1709   , (boolNot          , (1, genOperator1 AST.Not    ) )
1710   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1711   , (timesId          , (2, genTimes                ) )
1712   , (negateId         , (1, genNegation             ) )
1713   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1714   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1715   , (fromRangedWordId , (1, genFromRangedWord       ) )
1716   , (fromIntegerId    , (1, genFromInteger          ) )
1717   , (resizeWordId     , (1, genResize               ) )
1718   , (resizeIntId      , (1, genResize               ) )
1719   , (sizedIntId       , (1, genSizedInt             ) )
1720   , (smallIntegerId   , (1, genFromInteger          ) )
1721   , (fstId            , (1, genFst                  ) )
1722   , (sndId            , (1, genSnd                  ) )
1723   , (blockRAMId       , (5, genBlockRAM             ) )
1724   , (splitId          , (1, genSplit                ) )
1725   , (xorId            , (2, genOperator2 AST.Xor    ) )
1726   , (shiftLId         , (2, genSll                  ) )
1727   , (shiftRId         , (2, genSra                  ) )
1728   --, (tfvecId          , (1, genTFVec                ) )
1729   , (minimumId        , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
1730   ]