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