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