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