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