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