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