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