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