clash/CLasH/VHDL/Generate.hs

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