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