cλash/CLasH/VHDL/Generate.hs

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