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               case argsNostate of
1076                 [arg] -> do
1077                   [arg'] <- argsToVHDLExprs [arg]
1078                   return ([mkUncondAssign dst arg'], [])
1079                 otherwise ->
1080                   case htype_either of
1081                     Right htype@(AggrType _ _ _) -> do
1082                       let dc_i = datacon_index (Var.varType bndr) dc
1083                       let labels = getFieldLabels htype dc_i
1084                       args' <- argsToVHDLExprs argsNostate
1085                       return (zipWith mkassign labels args', [])
1086                       where
1087                         mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
1088                         mkassign label arg =
1089                           let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
1090                           mkUncondAssign (Right sel_name) arg
1091                     _ -> do -- error $ "DIE!"
1092                       args' <- argsToVHDLExprs argsNostate
1093                       return ([mkUncondAssign dst (head args')], [])
1094             Right _ -> error "\nGenerate.genApplication(DataConWorkId): Can't generate dataconstructor application without an original binder"
1095           IdInfo.DataConWrapId dc -> case dst of
1096             -- It's a datacon. Create a record from its arguments.
1097             Left bndr ->
1098               case (Map.lookup (varToString f) globalNameTable) of
1099                Just (arg_count, builder) ->
1100                 if length args == arg_count then
1101                   builder dst f args
1102                 else
1103                   error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1104                Nothing -> error $ "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper: " ++ (show dc)
1105             Right _ -> error "\nGenerate.genApplication(DataConWrapId): Can't generate dataconwrapper application without an original binder"
1106           IdInfo.VanillaId ->
1107             -- It's a global value imported from elsewhere. These can be builtin
1108             -- functions. Look up the function name in the name table and execute
1109             -- the associated builder if there is any and the argument count matches
1110             -- (this should always be the case if it typechecks, but just to be
1111             -- sure...).
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(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1118               Nothing -> do
1119                 top <- isTopLevelBinder f
1120                 if top then
1121                   do
1122                     -- Local binder that references a top level binding.  Generate a
1123                     -- component instantiation.
1124                     signature <- getEntity f
1125                     args' <- argsToVHDLExprs args
1126                     let entity_id = ent_id signature
1127                     -- TODO: Using show here isn't really pretty, but we'll need some
1128                     -- unique-ish value...
1129                     let label = "comp_ins_" ++ (either show prettyShow) dst
1130                     let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1131                     return ([mkComponentInst label entity_id portmaps], [f])
1132                   else
1133                     -- Not a top level binder, so this must be a local variable reference.
1134                     -- It should have a representable type (and thus, no arguments) and a
1135                     -- signal should be generated for it. Just generate an unconditional
1136                     -- assignment here.
1137                     -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1138                     -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1139                     --                   return $ ([mkUncondAssign dst f'], [])
1140                   do errtype <- case dst of
1141                         Left bndr -> do
1142                           htype <- MonadState.lift tsType $ mkHTypeEither (Var.varType bndr)
1143                           return (show htype)
1144                         Right vhd -> return $ show vhd
1145                      error ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f) ++ "::" ++ errtype)
1146           IdInfo.ClassOpId cls ->
1147             -- FIXME: Not looking for what instance this class op is called for
1148             -- Is quite stupid of course.
1149             case (Map.lookup (varToString f) globalNameTable) of
1150               Just (arg_count, builder) ->
1151                 if length args == arg_count then
1152                   builder dst f args
1153                 else
1154                   error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1155               Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1156           details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1157         else do
1158           top <- isTopLevelBinder f
1159           if top then
1160             do
1161                -- Local binder that references a top level binding.  Generate a
1162                -- component instantiation.
1163                signature <- getEntity f
1164                args' <- argsToVHDLExprs args
1165                let entity_id = ent_id signature
1166                -- TODO: Using show here isn't really pretty, but we'll need some
1167                -- unique-ish value...
1168                let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
1169                let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1170                return ([mkComponentInst label entity_id portmaps], [f])
1171             else
1172               -- Not a top level binder, so this must be a local variable reference.
1173               -- It should have a representable type (and thus, no arguments) and a
1174               -- signal should be generated for it. Just generate an unconditional
1175               -- assignment here.
1176             do f' <- MonadState.lift tsType $ varToVHDLExpr f
1177                return ([mkUncondAssign dst f'], [])
1178     else -- Destination has empty type, don't generate anything
1179       return ([], [])
1180 -----------------------------------------------------------------------------
1181 -- Functions to generate functions dealing with vectors.
1182 -----------------------------------------------------------------------------
1183
1184 -- Returns the VHDLId of the vector function with the given name for the given
1185 -- element type. Generates -- this function if needed.
1186 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1187 vectorFunId el_ty fname = do
1188   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1189   -- TODO: Handle the Nothing case?
1190   elemTM_maybe <- vhdlTy error_msg el_ty
1191   let elemTM = Maybe.fromMaybe
1192                  (error $ "\nGenerate.vectorFunId: Cannot generate vector function \"" ++ fname ++ "\" for the empty type \"" ++ (pprString el_ty) ++ "\"")
1193                  elemTM_maybe
1194   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1195   -- the VHDLState or something.
1196   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1197   typefuns <- MonadState.get tsTypeFuns
1198   el_htype <- mkHType error_msg el_ty
1199   case Map.lookup (UVecType el_htype, fname) typefuns of
1200     -- Function already generated, just return it
1201     Just (id, _) -> return id
1202     -- Function not generated yet, generate it
1203     Nothing -> do
1204       let functions = genUnconsVectorFuns elemTM vectorTM
1205       case lookup fname functions of
1206         Just body -> do
1207           MonadState.modify tsTypeFuns $ Map.insert (UVecType el_htype, fname) (function_id, (fst body))
1208           mapM_ (vectorFunId el_ty) (snd body)
1209           return function_id
1210         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1211   where
1212     function_id = mkVHDLExtId fname
1213
1214 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1215                     -> AST.TypeMark -- ^ type of the vector
1216                     -> [(String, (AST.SubProgBody, [String]))]
1217 genUnconsVectorFuns elemTM vectorTM  =
1218   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
1219   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1220   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
1221   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
1222   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1223   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
1224   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
1225   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1226   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr],[]))
1227   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1228   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
1229   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
1230   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1231   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1232   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1233   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1234   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1235   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1236   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1237   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1238   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1239   ]
1240   where
1241     ixPar   = AST.unsafeVHDLBasicId "ix"
1242     vecPar  = AST.unsafeVHDLBasicId "vec"
1243     vec1Par = AST.unsafeVHDLBasicId "vec1"
1244     vec2Par = AST.unsafeVHDLBasicId "vec2"
1245     nPar    = AST.unsafeVHDLBasicId "n"
1246     leftPar = AST.unsafeVHDLBasicId "nLeft"
1247     rightPar = AST.unsafeVHDLBasicId "nRight"
1248     iId     = AST.unsafeVHDLBasicId "i"
1249     iPar    = iId
1250     aPar    = AST.unsafeVHDLBasicId "a"
1251     fPar = AST.unsafeVHDLBasicId "f"
1252     sPar = AST.unsafeVHDLBasicId "s"
1253     resId   = AST.unsafeVHDLBasicId "res"
1254     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1255                                AST.IfaceVarDec ixPar  unsignedTM] elemTM
1256     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1257               (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple ixPar)]))
1258     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
1259                                           , AST.IfaceVarDec iPar   unsignedTM
1260                                           , AST.IfaceVarDec aPar   elemTM
1261                                           ] vectorTM
1262        -- variable res : fsvec_x (0 to vec'length-1);
1263     replaceVar =
1264          AST.VarDec resId
1265                 (AST.SubtypeIn vectorTM
1266                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1267                    [AST.ToRange (AST.PrimLit "0")
1268                             (AST.PrimName (AST.NAttribute $
1269                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1270                                 (AST.PrimLit "1"))   ]))
1271                 Nothing
1272        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1273     replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1274     replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1275     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1276     vecSlice init last =  AST.PrimName (AST.NSlice
1277                                         (AST.SliceName
1278                                               (AST.NSimple vecPar)
1279                                               (AST.ToRange init last)))
1280     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1281        -- return vec(vec'length-1);
1282     lastExpr = AST.ReturnSm (Just (AST.PrimName $ AST.NIndexed (AST.IndexedName
1283                     (AST.NSimple vecPar)
1284                     [AST.PrimName (AST.NAttribute $
1285                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1286                                                              AST.:-: AST.PrimLit "1"])))
1287     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1288        -- variable res : fsvec_x (0 to vec'length-2);
1289     initVar =
1290          AST.VarDec resId
1291                 (AST.SubtypeIn vectorTM
1292                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1293                    [AST.ToRange (AST.PrimLit "0")
1294                             (AST.PrimName (AST.NAttribute $
1295                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1296                                 (AST.PrimLit "2"))   ]))
1297                 Nothing
1298        -- resAST.:= vec(0 to vec'length-2)
1299     initExpr = AST.NSimple resId AST.:= (vecSlice
1300                                (AST.PrimLit "0")
1301                                (AST.PrimName (AST.NAttribute $
1302                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1303                                                              AST.:-: AST.PrimLit "2"))
1304     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1305     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
1306                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
1307     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1308                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1309                         []
1310                         (Just $ AST.Else [minimumExprRet])
1311       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1312     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
1313                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1314        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1315     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1316                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1317                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1318                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1319     takeVar =
1320          AST.VarDec resId
1321                 (AST.SubtypeIn vectorTM
1322                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1323                    [AST.ToRange (AST.PrimLit "0")
1324                                (minLength AST.:-:
1325                                 (AST.PrimLit "1"))   ]))
1326                 Nothing
1327        -- res AST.:= vec(0 to n-1)
1328     takeExpr = AST.NSimple resId AST.:=
1329                     (vecSlice (AST.PrimLit "0")
1330                               (minLength AST.:-: AST.PrimLit "1"))
1331     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1332     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
1333                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1334        -- variable res : fsvec_x (0 to vec'length-n-1);
1335     dropVar =
1336          AST.VarDec resId
1337                 (AST.SubtypeIn vectorTM
1338                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1339                    [AST.ToRange (AST.PrimLit "0")
1340                             (AST.PrimName (AST.NAttribute $
1341                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1342                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1343                Nothing
1344        -- res AST.:= vec(n to vec'length-1)
1345     dropExpr = AST.NSimple resId AST.:= (vecSlice
1346                                (AST.PrimName $ AST.NSimple nPar)
1347                                (AST.PrimName (AST.NAttribute $
1348                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1349                                                              AST.:-: AST.PrimLit "1"))
1350     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1351     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
1352                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
1353     -- variable res : fsvec_x (0 to vec'length);
1354     plusgtVar =
1355       AST.VarDec resId
1356              (AST.SubtypeIn vectorTM
1357                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1358                 [AST.ToRange (AST.PrimLit "0")
1359                         (AST.PrimName (AST.NAttribute $
1360                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1361              Nothing
1362     plusgtExpr = AST.NSimple resId AST.:=
1363                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1364                     (AST.PrimName $ AST.NSimple vecPar))
1365     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1366     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1367     emptyVar =
1368           AST.VarDec resId
1369             (AST.SubtypeIn vectorTM
1370               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1371                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1372              Nothing
1373     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1374     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1375                                          vectorTM
1376     -- variable res : fsvec_x (0 to 0) := (others => a);
1377     singletonVar =
1378       AST.VarDec resId
1379              (AST.SubtypeIn vectorTM
1380                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1381                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1382              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1383                                           (AST.PrimName $ AST.NSimple aPar)])
1384     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1385     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1386                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
1387     -- variable res : fsvec_x (0 to n-1) := (others => a);
1388     copynVar =
1389       AST.VarDec resId
1390              (AST.SubtypeIn vectorTM
1391                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1392                 [AST.ToRange (AST.PrimLit "0")
1393                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1394                              (AST.PrimLit "1"))   ]))
1395              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1396                                           (AST.PrimName $ AST.NSimple aPar)])
1397     -- return res
1398     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1399     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1400                                AST.IfaceVarDec sPar   naturalTM,
1401                                AST.IfaceVarDec nPar   naturalTM,
1402                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1403     -- variable res : fsvec_x (0 to n-1);
1404     selVar =
1405       AST.VarDec resId
1406                 (AST.SubtypeIn vectorTM
1407                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1408                     [AST.ToRange (AST.PrimLit "0")
1409                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1410                       (AST.PrimLit "1"))   ])
1411                 )
1412                 Nothing
1413     -- for i res'range loop
1414     --   res(i) := vec(f+i*s);
1415     -- end loop;
1416     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [selAssign]
1417     -- res(i) := vec(f+i*s);
1418     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1419                                 (AST.PrimName (AST.NSimple iId) AST.:*:
1420                                   AST.PrimName (AST.NSimple sPar)) in
1421                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1422                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1423     -- return res;
1424     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1425     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1426                                         AST.IfaceVarDec aPar   elemTM] vectorTM
1427      -- variable res : fsvec_x (0 to vec'length);
1428     ltplusVar =
1429       AST.VarDec resId
1430         (AST.SubtypeIn vectorTM
1431           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1432             [AST.ToRange (AST.PrimLit "0")
1433               (AST.PrimName (AST.NAttribute $
1434                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1435         Nothing
1436     ltplusExpr = AST.NSimple resId AST.:=
1437                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1438                       (AST.PrimName $ AST.NSimple aPar))
1439     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1440     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1441                                              AST.IfaceVarDec vec2Par vectorTM]
1442                                              vectorTM
1443     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1444     plusplusVar =
1445       AST.VarDec resId
1446         (AST.SubtypeIn vectorTM
1447           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1448             [AST.ToRange (AST.PrimLit "0")
1449               (AST.PrimName (AST.NAttribute $
1450                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1451                   AST.PrimName (AST.NAttribute $
1452                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1453                   AST.PrimLit "1")]))
1454        Nothing
1455     plusplusExpr = AST.NSimple resId AST.:=
1456                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1457                       (AST.PrimName $ AST.NSimple vec2Par))
1458     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1459     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1460     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1461                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1462     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1463                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM
1464     -- variable res : fsvec_x (0 to vec'length-1);
1465     shiftlVar =
1466      AST.VarDec resId
1467             (AST.SubtypeIn vectorTM
1468               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1469                [AST.ToRange (AST.PrimLit "0")
1470                         (AST.PrimName (AST.NAttribute $
1471                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1472                            (AST.PrimLit "1")) ]))
1473             Nothing
1474     -- res := a & init(vec)
1475     shiftlExpr = AST.NSimple resId AST.:=
1476                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1477                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1478                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1479     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1480     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1481                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM
1482     -- variable res : fsvec_x (0 to vec'length-1);
1483     shiftrVar =
1484      AST.VarDec resId
1485             (AST.SubtypeIn vectorTM
1486               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1487                [AST.ToRange (AST.PrimLit "0")
1488                         (AST.PrimName (AST.NAttribute $
1489                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1490                            (AST.PrimLit "1")) ]))
1491             Nothing
1492     -- res := tail(vec) & a
1493     shiftrExpr = AST.NSimple resId AST.:=
1494                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1495                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1496                   (AST.PrimName (AST.NSimple aPar)))
1497
1498     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1499     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1500     -- return vec'length = 0
1501     nullExpr = AST.ReturnSm (Just $
1502                 AST.PrimName (AST.NAttribute $
1503                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1504                     AST.PrimLit "0")
1505     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1506     -- variable res : fsvec_x (0 to vec'length-1);
1507     rotlVar =
1508      AST.VarDec resId
1509             (AST.SubtypeIn vectorTM
1510               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1511                [AST.ToRange (AST.PrimLit "0")
1512                         (AST.PrimName (AST.NAttribute $
1513                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1514                            (AST.PrimLit "1")) ]))
1515             Nothing
1516     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1517     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1518                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1519                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1520                         []
1521                         (Just $ AST.Else [rotlExprRet])
1522       where rotlExprRet =
1523                 AST.NSimple resId AST.:=
1524                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1525                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1526                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1527                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1528     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1529     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1530     -- variable res : fsvec_x (0 to vec'length-1);
1531     rotrVar =
1532      AST.VarDec resId
1533             (AST.SubtypeIn vectorTM
1534               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1535                [AST.ToRange (AST.PrimLit "0")
1536                         (AST.PrimName (AST.NAttribute $
1537                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1538                            (AST.PrimLit "1")) ]))
1539             Nothing
1540     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1541     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1542                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1543                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1544                         []
1545                         (Just $ AST.Else [rotrExprRet])
1546       where rotrExprRet =
1547                 AST.NSimple resId AST.:=
1548                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1549                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1550                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1551                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1552     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1553     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1554     reverseVar =
1555       AST.VarDec resId
1556              (AST.SubtypeIn vectorTM
1557                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1558                 [AST.ToRange (AST.PrimLit "0")
1559                          (AST.PrimName (AST.NAttribute $
1560                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1561                             (AST.PrimLit "1")) ]))
1562              Nothing
1563     -- for i in 0 to res'range loop
1564     --   res(vec'length-i-1) := vec(i);
1565     -- end loop;
1566     reverseFor =
1567        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple rangeId) Nothing) [reverseAssign]
1568     -- res(vec'length-i-1) := vec(i);
1569     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1570       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1571                            [AST.PrimName $ AST.NSimple iId]))
1572         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1573                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1574                         AST.PrimName (AST.NSimple iId) AST.:-:
1575                         (AST.PrimLit "1")
1576     -- return res;
1577     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1578
1579
1580 -----------------------------------------------------------------------------
1581 -- A table of builtin functions
1582 -----------------------------------------------------------------------------
1583
1584 -- A function that generates VHDL for a builtin function
1585 type BuiltinBuilder =
1586   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1587   -> CoreSyn.CoreBndr -- ^ The function called
1588   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1589                     --   dictionary arguments).
1590   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1591   -- ^ The corresponding VHDL concurrent statements and entities
1592   --   instantiated.
1593
1594 -- A map of a builtin function to VHDL function builder
1595 type NameTable = Map.Map String (Int, BuiltinBuilder )
1596
1597 -- | The builtin functions we support. Maps a name to an argument count and a
1598 -- builder function. If you add a name to this map, don't forget to add
1599 -- it to VHDL.Constants/builtinIds as well.
1600 globalNameTable :: NameTable
1601 globalNameTable = Map.fromList
1602   [ (exId             , (2, genFCall True          ) )
1603   , (replaceId        , (3, genFCall False          ) )
1604   , (headId           , (1, genFCall True           ) )
1605   , (lastId           , (1, genFCall True           ) )
1606   , (tailId           , (1, genFCall False          ) )
1607   , (initId           , (1, genFCall False          ) )
1608   , (takeId           , (2, genFCall False          ) )
1609   , (dropId           , (2, genFCall False          ) )
1610   , (selId            , (4, genFCall False          ) )
1611   , (plusgtId         , (2, genFCall False          ) )
1612   , (ltplusId         , (2, genFCall False          ) )
1613   , (plusplusId       , (2, genFCall False          ) )
1614   , (mapId            , (2, genMap                  ) )
1615   , (zipWithId        , (3, genZipWith              ) )
1616   , (foldlId          , (3, genFoldl                ) )
1617   , (foldrId          , (3, genFoldr                ) )
1618   , (zipId            , (2, genZip                  ) )
1619   , (unzipId          , (1, genUnzip                ) )
1620   , (shiftlId         , (2, genFCall False          ) )
1621   , (shiftrId         , (2, genFCall False          ) )
1622   , (rotlId           , (1, genFCall False          ) )
1623   , (rotrId           , (1, genFCall False          ) )
1624   , (concatId         , (1, genConcat               ) )
1625   , (reverseId        , (1, genFCall False          ) )
1626   , (iteratenId       , (3, genIteraten             ) )
1627   , (iterateId        , (2, genIterate              ) )
1628   , (generatenId      , (3, genGeneraten            ) )
1629   , (generateId       , (2, genGenerate             ) )
1630   , (emptyId          , (0, genFCall False          ) )
1631   , (singletonId      , (1, genFCall False          ) )
1632   , (copynId          , (2, genFCall False          ) )
1633   , (copyId           , (1, genCopy                 ) )
1634   , (lengthTId        , (1, genFCall False          ) )
1635   , (nullId           , (1, genFCall False          ) )
1636   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1637   , (hwandId          , (2, genOperator2 AST.And    ) )
1638   , (hworId           , (2, genOperator2 AST.Or     ) )
1639   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1640   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
1641   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )
1642   , (ltId             , (2, genOperator2 (AST.:<:)  ) )
1643   , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
1644   , (gtId             , (2, genOperator2 (AST.:>:)  ) )
1645   , (gteqId           , (2, genOperator2 (AST.:>=:) ) )
1646   , (boolOrId         , (2, genOperator2 AST.Or     ) )
1647   , (boolAndId        , (2, genOperator2 AST.And    ) )
1648   , (boolNot          , (1, genOperator1 AST.Not    ) )
1649   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1650   , (timesId          , (2, genTimes                ) )
1651   , (negateId         , (1, genNegation             ) )
1652   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1653   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1654   , (fromRangedWordId , (1, genFromRangedWord       ) )
1655   , (fromIntegerId    , (1, genFromInteger          ) )
1656   , (resizeWordId     , (1, genResize               ) )
1657   , (resizeIntId      , (1, genResize               ) )
1658   , (sizedIntId       , (1, genSizedInt             ) )
1659   , (smallIntegerId   , (1, genFromInteger          ) )
1660   , (fstId            , (1, genFst                  ) )
1661   , (sndId            , (1, genSnd                  ) )
1662   , (blockRAMId       , (5, genBlockRAM             ) )
1663   , (splitId          , (1, genSplit                ) )
1664   --, (tfvecId          , (1, genTFVec                ) )
1665   , (minimumId        , (2, error "\nFunction name: \"minimum\" is used internally, use another name"))
1666   ]