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