cλash/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 Data.Accessor
  10 import Data.Accessor.MonadState as MonadState
  11 import Debug.Trace
  12
  13 -- ForSyDe
  14 import qualified Language.VHDL.AST as AST
  15
  16 -- GHC API
  17 import qualified CoreSyn
  18 import qualified Type
  19 import qualified Var
  20 import qualified Id
  21 import qualified IdInfo
  22 import qualified Literal
  23 import qualified Name
  24 import qualified TyCon
  25
  26 -- Local imports
  27 import CLasH.Translator.TranslatorTypes
  28 import CLasH.VHDL.Constants
  29 import CLasH.VHDL.VHDLTypes
  30 import CLasH.VHDL.VHDLTools
  31 import CLasH.Utils as Utils
  32 import CLasH.Utils.Core.CoreTools
  33 import CLasH.Utils.Pretty
  34 import qualified CLasH.Normalize as Normalize
  35
  36 -----------------------------------------------------------------------------
  37 -- Functions to generate VHDL for user-defined functions.
  38 -----------------------------------------------------------------------------
  39
  40 -- | Create an entity for a given function
  41 getEntity ::
  42   CoreSyn.CoreBndr
  43   -> TranslatorSession Entity -- ^ The resulting entity
  44
  45 getEntity fname = Utils.makeCached fname tsEntities $ do
  46       expr <- Normalize.getNormalized fname
  47       -- Split the normalized expression
  48       let (args, binds, res) = Normalize.splitNormalized expr
  49       -- Generate ports for all non-empty types
  50       args' <- catMaybesM $ mapM mkMap args
  51       -- TODO: Handle Nothing
  52       res' <- mkMap res
  53       let vhdl_id = mkVHDLBasicId $ varToString fname ++ "_" ++ varToStringUniq fname
  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 $ vhdl_ty 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]
  92     -- Add a clk port if we have state
  93     clk_port = AST.IfaceSigDec clockId AST.In std_logicTM
  94     res_port = fmap (mkIfaceSigDec AST.Out) res
  95
  96 -- | Create a port declaration
  97 mkIfaceSigDec ::
  98   AST.Mode                         -- ^ The mode for the port (In / Out)
  99   -> Port                          -- ^ The id and type for the port
 100   -> AST.IfaceSigDec               -- ^ The resulting port declaration
 101
 102 mkIfaceSigDec mode (id, ty) = AST.IfaceSigDec id mode ty
 103
 104 -- | Create an architecture for a given function
 105 getArchitecture ::
 106   CoreSyn.CoreBndr -- ^ The function to get an architecture for
 107   -> TranslatorSession (Architecture, [CoreSyn.CoreBndr])
 108   -- ^ The architecture for this function
 109
 110 getArchitecture fname = Utils.makeCached fname tsArchitectures $ do
 111   expr <- Normalize.getNormalized fname
 112   -- Split the normalized expression
 113   let (args, binds, res) = Normalize.splitNormalized expr
 114
 115   -- Get the entity for this function
 116   signature <- getEntity fname
 117   let entity_id = ent_id signature
 118
 119   -- Create signal declarations for all binders in the let expression, except
 120   -- for the output port (that will already have an output port declared in
 121   -- the entity).
 122   sig_dec_maybes <- mapM (mkSigDec . fst) (filter ((/=res).fst) binds)
 123   let sig_decs = Maybe.catMaybes $ sig_dec_maybes
 124   -- Process each bind, resulting in info about state variables and concurrent
 125   -- statements.
 126   (state_vars, sms) <- Monad.mapAndUnzipM dobind binds
 127   let (in_state_maybes, out_state_maybes) = unzip state_vars
 128   let (statementss, used_entitiess) = unzip sms
 129   -- Create a state proc, if needed
 130   let state_proc = case (Maybe.catMaybes in_state_maybes, Maybe.catMaybes out_state_maybes) of
 131         ([in_state], [out_state]) -> [AST.CSPSm $ mkStateProcSm (in_state, out_state)]
 132         ([], []) -> []
 133         (ins, outs) -> error $ "Weird use of state in " ++ show fname ++ ". In: " ++ show ins ++ " Out: " ++ show outs
 134   -- Join the create statements and the (optional) state_proc
 135   let statements = concat statementss ++ state_proc
 136   -- Create the architecture
 137   let arch = AST.ArchBody (mkVHDLBasicId "structural") (AST.NSimple entity_id) (map AST.BDISD sig_decs) statements
 138   let used_entities = concat used_entitiess
 139   return (arch, used_entities)
 140   where
 141     dobind :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The bind to process
 142               -> TranslatorSession ((Maybe CoreSyn.CoreBndr, Maybe CoreSyn.CoreBndr), ([AST.ConcSm], [CoreSyn.CoreBndr]))
 143               -- ^ ((Input state variable, output state variable), (statements, used entities))
 144     -- newtype unpacking is just a cast
 145     dobind (bndr, (CoreSyn.Cast expr coercion))
 146       | hasStateType expr
 147       = return ((Just bndr, Nothing), ([], []))
 148     -- With simplCore, newtype packing is just a cast
 149     dobind (bndr, expr@(CoreSyn.Cast (CoreSyn.Var state) coercion))
 150       | hasStateType expr
 151       = return ((Nothing, Just state), ([], []))
 152     -- Without simplCore, newtype packing uses a data constructor
 153     dobind (bndr, (CoreSyn.App (CoreSyn.App (CoreSyn.Var con) (CoreSyn.Type _)) (CoreSyn.Var state)))
 154       | isStateCon con
 155       = return ((Nothing, Just state), ([], []))
 156     -- Anything else is handled by mkConcSm
 157     dobind bind = do
 158       sms <- mkConcSm bind
 159       return ((Nothing, Nothing), sms)
 160
 161 mkStateProcSm ::
 162   (CoreSyn.CoreBndr, CoreSyn.CoreBndr) -- ^ The current and new state variables
 163   -> AST.ProcSm -- ^ The resulting statement
 164 mkStateProcSm (old, new) =
 165   AST.ProcSm label [clk] [statement]
 166   where
 167     label       = mkVHDLBasicId $ "state"
 168     clk         = mkVHDLBasicId "clock"
 169     rising_edge = AST.NSimple $ mkVHDLBasicId "rising_edge"
 170     wform       = AST.Wform [AST.WformElem (AST.PrimName $ varToVHDLName new) Nothing]
 171     assign      = AST.SigAssign (varToVHDLName old) wform
 172     rising_edge_clk = AST.PrimFCall $ AST.FCall rising_edge [Nothing AST.:=>: (AST.ADName $ AST.NSimple clk)]
 173     statement   = AST.IfSm rising_edge_clk [assign] [] Nothing
 174
 175
 176 -- | Transforms a core binding into a VHDL concurrent statement
 177 mkConcSm ::
 178   (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -- ^ The binding to process
 179   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 180   -- ^ The corresponding VHDL concurrent statements and entities
 181   --   instantiated.
 182
 183
 184 -- Ignore Cast expressions, they should not longer have any meaning as long as
 185 -- the type works out.
 186 mkConcSm (bndr, CoreSyn.Cast expr ty) = mkConcSm (bndr, expr)
 187
 188 -- Simple a = b assignments are just like applications, but without arguments.
 189 -- We can't just generate an unconditional assignment here, since b might be a
 190 -- top level binding (e.g., a function with no arguments).
 191 mkConcSm (bndr, CoreSyn.Var v) = do
 192   genApplication (Left bndr) v []
 193
 194 mkConcSm (bndr, app@(CoreSyn.App _ _))= do
 195   let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 196   let valargs = get_val_args (Var.varType f) args
 197   genApplication (Left bndr) f (map Left valargs)
 198
 199 -- A single alt case must be a selector. This means thee scrutinee is a simple
 200 -- variable, the alternative is a dataalt with a single non-wild binder that
 201 -- is also returned.
 202 mkConcSm (bndr, expr@(CoreSyn.Case (CoreSyn.Var scrut) b ty [alt]))
 203                 -- Don't generate VHDL for substate extraction
 204                 | hasStateType bndr = return ([], [])
 205                 | otherwise =
 206   case alt of
 207     (CoreSyn.DataAlt dc, bndrs, (CoreSyn.Var sel_bndr)) -> do
 208       bndrs' <- Monad.filterM hasNonEmptyType bndrs
 209       case List.elemIndex sel_bndr bndrs' of
 210         Just i -> do
 211           labels <- MonadState.lift tsType $ getFieldLabels (Id.idType scrut)
 212           let label = labels!!i
 213           let sel_name = mkSelectedName (varToVHDLName scrut) label
 214           let sel_expr = AST.PrimName sel_name
 215           return ([mkUncondAssign (Left bndr) sel_expr], [])
 216         Nothing -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 217
 218     _ -> error $ "\nVHDL.mkConcSM: Not in normal form: Not a selector case:\n" ++ (pprString expr)
 219
 220 -- Multiple case alt are be conditional assignments and have only wild
 221 -- binders in the alts and only variables in the case values and a variable
 222 -- for a scrutinee. We check the constructor of the second alt, since the
 223 -- first is the default case, if there is any.
 224 mkConcSm (bndr, (CoreSyn.Case (CoreSyn.Var scrut) b ty [(_, _, CoreSyn.Var false), (con, _, CoreSyn.Var true)])) = do
 225   scrut' <- MonadState.lift tsType $ varToVHDLExpr scrut
 226   let cond_expr = scrut' AST.:=: (altconToVHDLExpr con)
 227   true_expr <- MonadState.lift tsType $ varToVHDLExpr true
 228   false_expr <- MonadState.lift tsType $ varToVHDLExpr false
 229   return ([mkCondAssign (Left bndr) cond_expr true_expr false_expr], [])
 230
 231 mkConcSm (_, (CoreSyn.Case (CoreSyn.Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives"
 232 mkConcSm (_, CoreSyn.Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee"
 233 mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr
 234
 235 -----------------------------------------------------------------------------
 236 -- Functions to generate VHDL for builtin functions
 237 -----------------------------------------------------------------------------
 238
 239 -- | A function to wrap a builder-like function that expects its arguments to
 240 -- be expressions.
 241 genExprArgs wrap dst func args = do
 242   args' <- argsToVHDLExprs args
 243   wrap dst func args'
 244
 245 -- | Turn the all lefts into VHDL Expressions.
 246 argsToVHDLExprs :: [Either CoreSyn.CoreExpr AST.Expr] -> TranslatorSession [AST.Expr]
 247 argsToVHDLExprs = catMaybesM . (mapM argToVHDLExpr)
 248
 249 argToVHDLExpr :: Either CoreSyn.CoreExpr AST.Expr -> TranslatorSession (Maybe AST.Expr)
 250 argToVHDLExpr (Left expr) = MonadState.lift tsType $ do
 251   let errmsg = "Generate.argToVHDLExpr: Using non-representable type? Should not happen!"
 252   ty_maybe <- vhdl_ty errmsg expr
 253   case ty_maybe of
 254     Just _ -> do
 255       vhdl_expr <- varToVHDLExpr $ exprToVar expr
 256       return $ Just vhdl_expr
 257     Nothing -> return $ Nothing
 258
 259 argToVHDLExpr (Right expr) = return $ Just expr
 260
 261 -- A function to wrap a builder-like function that generates no component
 262 -- instantiations
 263 genNoInsts ::
 264   (dst -> func -> args -> TranslatorSession [AST.ConcSm])
 265   -> (dst -> func -> args -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr]))
 266 genNoInsts wrap dst func args = do
 267   concsms <- wrap dst func args
 268   return (concsms, [])
 269
 270 -- | A function to wrap a builder-like function that expects its arguments to
 271 -- be variables.
 272 genVarArgs ::
 273   (dst -> func -> [Var.Var] -> res)
 274   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
 275 genVarArgs wrap dst func args = wrap dst func args'
 276   where
 277     args' = map exprToVar exprargs
 278     -- Check (rather crudely) that all arguments are CoreExprs
 279     (exprargs, []) = Either.partitionEithers args
 280
 281 -- | A function to wrap a builder-like function that expects its arguments to
 282 -- be Literals
 283 genLitArgs ::
 284   (dst -> func -> [Literal.Literal] -> res)
 285   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
 286 genLitArgs wrap dst func args = wrap dst func args'
 287   where
 288     args' = map exprToLit litargs
 289     -- FIXME: Check if we were passed an CoreSyn.App
 290     litargs = concat (map getLiterals exprargs)
 291     (exprargs, []) = Either.partitionEithers args
 292
 293 -- | A function to wrap a builder-like function that produces an expression
 294 -- and expects it to be assigned to the destination.
 295 genExprRes ::
 296   ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession AST.Expr)
 297   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> TranslatorSession [AST.ConcSm])
 298 genExprRes wrap dst func args = do
 299   expr <- wrap dst func args
 300   return $ [mkUncondAssign dst expr]
 301
 302 -- | Generate a binary operator application. The first argument should be a
 303 -- constructor from the AST.Expr type, e.g. AST.And.
 304 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
 305 genOperator2 op = genNoInsts $ genExprArgs $ genExprRes (genOperator2' op)
 306 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
 307 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
 308
 309 -- | Generate a unary operator application
 310 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
 311 genOperator1 op = genNoInsts $ genExprArgs $ genExprRes (genOperator1' op)
 312 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
 313 genOperator1' op _ f [arg] = return $ op arg
 314
 315 -- | Generate a unary operator application
 316 genNegation :: BuiltinBuilder
 317 genNegation = genNoInsts $ genVarArgs $ genExprRes genNegation'
 318 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession AST.Expr
 319 genNegation' _ f [arg] = do
 320   arg1 <- MonadState.lift tsType $ varToVHDLExpr arg
 321   let ty = Var.varType arg
 322   let (tycon, args) = Type.splitTyConApp ty
 323   let name = Name.getOccString (TyCon.tyConName tycon)
 324   case name of
 325     "SizedInt" -> return $ AST.Neg arg1
 326     otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
 327
 328 -- | Generate a function call from the destination binder, function name and a
 329 -- list of expressions (its arguments)
 330 genFCall :: Bool -> BuiltinBuilder
 331 genFCall switch = genNoInsts $ genExprArgs $ genExprRes (genFCall' switch)
 332 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
 333 genFCall' switch (Left res) f args = do
 334   let fname = varToString f
 335   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
 336   id <- MonadState.lift tsType $ vectorFunId el_ty fname
 337   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
 338              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 339 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 340
 341 genFromSizedWord :: BuiltinBuilder
 342 genFromSizedWord = genNoInsts $ genExprArgs $ genExprRes genFromSizedWord'
 343 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
 344 genFromSizedWord' (Left res) f args = do
 345   let fname = varToString f
 346   return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
 347              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 348 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 349
 350 genResize :: BuiltinBuilder
 351 genResize = genNoInsts $ genExprArgs $ genExprRes genResize'
 352 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> TranslatorSession AST.Expr
 353 genResize' (Left res) f [arg] = do {
 354   ; let { ty = Var.varType res
 355         ; (tycon, args) = Type.splitTyConApp ty
 356         ; name = Name.getOccString (TyCon.tyConName tycon)
 357         } ;
 358   ; len <- case name of
 359       "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
 360       "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
 361   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
 362              [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
 363   }
 364 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 365
 366 -- FIXME: I'm calling genLitArgs which is very specific function,
 367 -- which needs to be fixed as well
 368 genFromInteger :: BuiltinBuilder
 369 genFromInteger = genNoInsts $ genLitArgs $ genExprRes genFromInteger'
 370 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> TranslatorSession AST.Expr
 371 genFromInteger' (Left res) f lits = do {
 372   ; let { ty = Var.varType res
 373         ; (tycon, args) = Type.splitTyConApp ty
 374         ; name = Name.getOccString (TyCon.tyConName tycon)
 375         } ;
 376   ; case name of
 377     "RangedWord" -> return $ AST.PrimLit (show (last lits))
 378     otherwise -> do {
 379       ; len <- case name of
 380         "SizedInt" -> MonadState.lift tsType $ tfp_to_int (sized_int_len_ty ty)
 381         "SizedWord" -> MonadState.lift tsType $ tfp_to_int (sized_word_len_ty ty)
 382         "RangedWord" -> MonadState.lift tsType $ tfp_to_int (ranged_word_bound_ty ty)
 383       ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
 384       ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
 385                 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
 386       }
 387   }
 388
 389 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 390
 391 genSizedInt :: BuiltinBuilder
 392 genSizedInt = genFromInteger
 393
 394 {-
 395 -- | Generate a Builder for the builtin datacon TFVec
 396 genTFVec :: BuiltinBuilder
 397 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
 398   -- Generate Assignments for all the binders
 399   ; letAssigns <- mapM genBinderAssign letBinders
 400   -- Generate assignments for the result (which might be another let binding)
 401   ; (resBinders,resAssignments) <- genResAssign letRes
 402   -- Get all the Assigned binders
 403   ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
 404   -- Make signal names for all the assigned binders
 405   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
 406   -- Assign all the signals to the resulting vector
 407   ; let { vecsigns = mkAggregateSignal sigs
 408         ; vecassign = mkUncondAssign (Left res) vecsigns
 409         } ;
 410   -- Generate all the signal declaration for the assigned binders
 411   ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
 412   ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
 413   -- Setup the VHDL Block
 414         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
 415         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
 416         } ;
 417   -- Return the block statement coressponding to the TFVec literal
 418   ; return $ [AST.CSBSm block]
 419   }
 420   where
 421     genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> TranslatorSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
 422     -- For now we only translate applications
 423     genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
 424       let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 425       let valargs = get_val_args (Var.varType f) args
 426       apps <- genApplication (Left bndr) f (map Left valargs)
 427       return (Just bndr, apps)
 428     genBinderAssign _ = return (Nothing,[])
 429     genResAssign :: CoreSyn.CoreExpr -> TranslatorSession ([CoreSyn.CoreBndr], [AST.ConcSm])
 430     genResAssign app@(CoreSyn.App _ letexpr) = do
 431       case letexpr of
 432         (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
 433           letapps <- mapM genBinderAssign letbndrs
 434           let bndrs = Maybe.catMaybes (map fst letapps)
 435           let app = (map snd letapps)
 436           (vars, apps) <- genResAssign letres
 437           return ((bndrs ++ vars),((concat app) ++ apps))
 438         otherwise -> return ([],[])
 439     genResAssign _ = return ([],[])
 440
 441 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
 442   ; let { elems = reduceCoreListToHsList app
 443   -- Make signal names for all the binders
 444         ; binders = map (\expr -> case expr of
 445                           (CoreSyn.Var b) -> b
 446                           otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
 447                             ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
 448         } ;
 449   ; sigs <- mapM (\x -> MonadState.lift tsType $ varToVHDLExpr x) binders
 450   -- Assign all the signals to the resulting vector
 451   ; let { vecsigns = mkAggregateSignal sigs
 452         ; vecassign = mkUncondAssign (Left res) vecsigns
 453   -- Setup the VHDL Block
 454         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
 455         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
 456         } ;
 457   -- Return the block statement coressponding to the TFVec literal
 458   ; return $ [AST.CSBSm block]
 459   }
 460
 461 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
 462
 463 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
 464 -}
 465 -- | Generate a generate statement for the builtin function "map"
 466 genMap :: BuiltinBuilder
 467 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
 468   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
 469   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
 470   -- we must index it (which we couldn't if it was a VHDL Expr, since only
 471   -- VHDLNames can be indexed).
 472   -- Setup the generate scheme
 473   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 474           -- TODO: Use something better than varToString
 475   ; let { label       = mkVHDLExtId ("mapVector" ++ (varToString res))
 476         ; n_id        = mkVHDLBasicId "n"
 477         ; n_expr      = idToVHDLExpr n_id
 478         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 479         ; genScheme   = AST.ForGn n_id range
 480           -- Create the content of the generate statement: Applying the mapped_f to
 481           -- each of the elements in arg, storing to each element in res
 482         ; resname     = mkIndexedName (varToVHDLName res) n_expr
 483         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
 484         ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
 485         ; valargs = get_val_args (Var.varType real_f) already_mapped_args
 486         } ;
 487   ; (app_concsms, used) <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
 488     -- Return the generate statement
 489   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
 490   }
 491
 492 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
 493
 494 genZipWith :: BuiltinBuilder
 495 genZipWith = genVarArgs genZipWith'
 496 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 497 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
 498   -- Setup the generate scheme
 499   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 500           -- TODO: Use something better than varToString
 501   ; let { label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
 502         ; n_id        = mkVHDLBasicId "n"
 503         ; n_expr      = idToVHDLExpr n_id
 504         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 505         ; genScheme   = AST.ForGn n_id range
 506           -- Create the content of the generate statement: Applying the zipped_f to
 507           -- each of the elements in arg1 and arg2, storing to each element in res
 508         ; resname     = mkIndexedName (varToVHDLName res) n_expr
 509         ; argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
 510         ; argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
 511         } ;
 512   ; (app_concsms, used) <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
 513     -- Return the generate functions
 514   ; return ([AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms], used)
 515   }
 516
 517 genFoldl :: BuiltinBuilder
 518 genFoldl = genFold True
 519
 520 genFoldr :: BuiltinBuilder
 521 genFoldr = genFold False
 522
 523 genFold :: Bool -> BuiltinBuilder
 524 genFold left = genVarArgs (genFold' left)
 525
 526 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 527 genFold' left res f args@[folded_f , start ,vec]= do
 528   len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
 529   genFold'' len left res f args
 530
 531 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 532 -- Special case for an empty input vector, just assign start to res
 533 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
 534   arg <- MonadState.lift tsType $ varToVHDLExpr start
 535   return ([mkUncondAssign (Left res) arg], [])
 536
 537 genFold'' len left (Left res) f [folded_f, start, vec] = do
 538   -- The vector length
 539   --len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 540   -- An expression for len-1
 541   let len_min_expr = (AST.PrimLit $ show (len-1))
 542   -- evec is (TFVec n), so it still needs an element type
 543   let (nvec, _) = Type.splitAppTy (Var.varType vec)
 544   -- Put the type of the start value in nvec, this will be the type of our
 545   -- temporary vector
 546   let tmp_ty = Type.mkAppTy nvec (Var.varType start)
 547   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
 548   -- TODO: Handle Nothing
 549   Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
 550   -- Setup the generate scheme
 551   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
 552   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
 553   let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
 554                   else AST.DownRange len_min_expr (AST.PrimLit "0")
 555   let gen_scheme   = AST.ForGn n_id gen_range
 556   -- Make the intermediate vector
 557   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
 558   -- Create the generate statement
 559   cells' <- sequence [genFirstCell, genOtherCell]
 560   let (cells, useds) = unzip cells'
 561   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
 562   -- Assign tmp[len-1] or tmp[0] to res
 563   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
 564                     (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
 565                     (mkIndexedName tmp_name (AST.PrimLit "0")))
 566   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
 567   return ([AST.CSBSm block], concat useds)
 568   where
 569     -- An id for the counter
 570     n_id = mkVHDLBasicId "n"
 571     n_cur = idToVHDLExpr n_id
 572     -- An expression for previous n
 573     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
 574                      else (n_cur AST.:+: (AST.PrimLit "1"))
 575     -- An id for the tmp result vector
 576     tmp_id = mkVHDLBasicId "tmp"
 577     tmp_name = AST.NSimple tmp_id
 578     -- Generate parts of the fold
 579     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
 580     genFirstCell = do
 581       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 582       let cond_label = mkVHDLExtId "firstcell"
 583       -- if n == 0 or n == len-1
 584       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
 585                                                   else (AST.PrimLit $ show (len-1)))
 586       -- Output to tmp[current n]
 587       let resname = mkIndexedName tmp_name n_cur
 588       -- Input from start
 589       argexpr1 <- MonadState.lift tsType $ varToVHDLExpr start
 590       -- Input from vec[current n]
 591       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
 592       (app_concsms, used) <- genApplication (Right resname) folded_f  ( if left then
 593                                                                   [Right argexpr1, Right argexpr2]
 594                                                                 else
 595                                                                   [Right argexpr2, Right argexpr1]
 596                                                               )
 597       -- Return the conditional generate part
 598       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
 599
 600     genOtherCell = do
 601       len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 602       let cond_label = mkVHDLExtId "othercell"
 603       -- if n > 0 or n < len-1
 604       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
 605                                                    else (AST.PrimLit $ show (len-1)))
 606       -- Output to tmp[current n]
 607       let resname = mkIndexedName tmp_name n_cur
 608       -- Input from tmp[previous n]
 609       let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
 610       -- Input from vec[current n]
 611       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
 612       (app_concsms, used) <- genApplication (Right resname) folded_f  ( if left then
 613                                                                   [Right argexpr1, Right argexpr2]
 614                                                                 else
 615                                                                   [Right argexpr2, Right argexpr1]
 616                                                               )
 617       -- Return the conditional generate part
 618       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
 619
 620 -- | Generate a generate statement for the builtin function "zip"
 621 genZip :: BuiltinBuilder
 622 genZip = genNoInsts $ genVarArgs genZip'
 623 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
 624 genZip' (Left res) f args@[arg1, arg2] = do {
 625     -- Setup the generate scheme
 626   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 627           -- TODO: Use something better than varToString
 628   ; let { label           = mkVHDLExtId ("zipVector" ++ (varToString res))
 629         ; n_id            = mkVHDLBasicId "n"
 630         ; n_expr          = idToVHDLExpr n_id
 631         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 632         ; genScheme       = AST.ForGn n_id range
 633         ; resname'        = mkIndexedName (varToVHDLName res) n_expr
 634         ; argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
 635         ; argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
 636         } ;
 637   ; labels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType res))
 638   ; let { resnameA    = mkSelectedName resname' (labels!!0)
 639         ; resnameB    = mkSelectedName resname' (labels!!1)
 640         ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
 641         ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
 642         } ;
 643     -- Return the generate functions
 644   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
 645   }
 646
 647 -- | Generate a generate statement for the builtin function "unzip"
 648 genUnzip :: BuiltinBuilder
 649 genUnzip = genNoInsts $ genVarArgs genUnzip'
 650 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
 651 genUnzip' (Left res) f args@[arg] = do {
 652     -- Setup the generate scheme
 653   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 654     -- TODO: Use something better than varToString
 655   ; let { label           = mkVHDLExtId ("unzipVector" ++ (varToString res))
 656         ; n_id            = mkVHDLBasicId "n"
 657         ; n_expr          = idToVHDLExpr n_id
 658         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 659         ; genScheme       = AST.ForGn n_id range
 660         ; resname'        = varToVHDLName res
 661         ; argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
 662         } ;
 663   ; reslabels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
 664   ; arglabels <- MonadState.lift tsType $ getFieldLabels (tfvec_elem (Var.varType arg))
 665   ; let { resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
 666         ; resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
 667         ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
 668         ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
 669         ; resA_assign = mkUncondAssign (Right resnameA) argexprA
 670         ; resB_assign = mkUncondAssign (Right resnameB) argexprB
 671         } ;
 672     -- Return the generate functions
 673   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
 674   }
 675
 676 genCopy :: BuiltinBuilder
 677 genCopy = genNoInsts $ genVarArgs genCopy'
 678 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
 679 genCopy' (Left res) f args@[arg] =
 680   let
 681     resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 682                 (AST.PrimName $ (varToVHDLName arg))]
 683     out_assign = mkUncondAssign (Left res) resExpr
 684   in
 685     return [out_assign]
 686
 687 genConcat :: BuiltinBuilder
 688 genConcat = genNoInsts $ genVarArgs genConcat'
 689 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
 690 genConcat' (Left res) f args@[arg] = do {
 691     -- Setup the generate scheme
 692   ; len1 <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 693   ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
 694   ; len2 <- MonadState.lift tsType $ tfp_to_int $ tfvec_len_ty nvec
 695           -- TODO: Use something better than varToString
 696   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))
 697         ; n_id        = mkVHDLBasicId "n"
 698         ; n_expr      = idToVHDLExpr n_id
 699         ; fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
 700         ; genScheme   = AST.ForGn n_id range
 701           -- Create the content of the generate statement: Applying the mapped_f to
 702           -- each of the elements in arg, storing to each element in res
 703         ; toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
 704         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
 705         ; resname     = vecSlice fromRange toRange
 706         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
 707         ; out_assign  = mkUncondAssign (Right resname) argexpr
 708         } ;
 709     -- Return the generate statement
 710   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
 711   }
 712   where
 713     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res)
 714                             (AST.ToRange init last))
 715
 716 genIteraten :: BuiltinBuilder
 717 genIteraten dst f args = genIterate dst f (tail args)
 718
 719 genIterate :: BuiltinBuilder
 720 genIterate = genIterateOrGenerate True
 721
 722 genGeneraten :: BuiltinBuilder
 723 genGeneraten dst f args = genGenerate dst f (tail args)
 724
 725 genGenerate :: BuiltinBuilder
 726 genGenerate = genIterateOrGenerate False
 727
 728 genIterateOrGenerate :: Bool -> BuiltinBuilder
 729 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
 730
 731 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 732 genIterateOrGenerate' iter (Left res) f args = do
 733   len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
 734   genIterateOrGenerate'' len iter (Left res) f args
 735
 736 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 737 -- Special case for an empty input vector, just assign start to res
 738 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return ([mkUncondAssign (Left res) (AST.PrimLit "\"\"")], [])
 739
 740 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
 741   -- The vector length
 742   -- len <- MonadState.lift tsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
 743   -- An expression for len-1
 744   let len_min_expr = (AST.PrimLit $ show (len-1))
 745   -- -- evec is (TFVec n), so it still needs an element type
 746   -- let (nvec, _) = splitAppTy (Var.varType vec)
 747   -- -- Put the type of the start value in nvec, this will be the type of our
 748   -- -- temporary vector
 749   let tmp_ty = Var.varType res
 750   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
 751   -- TODO: Handle Nothing
 752   Just tmp_vhdl_ty <- MonadState.lift tsType $ vhdl_ty error_msg tmp_ty
 753   -- Setup the generate scheme
 754   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
 755   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
 756   let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
 757   let gen_scheme   = AST.ForGn n_id gen_range
 758   -- Make the intermediate vector
 759   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
 760   -- Create the generate statement
 761   cells' <- sequence [genFirstCell, genOtherCell]
 762   let (cells, useds) = unzip cells'
 763   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
 764   -- Assign tmp[len-1] or tmp[0] to res
 765   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
 766   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
 767   return ([AST.CSBSm block], concat useds)
 768   where
 769     -- An id for the counter
 770     n_id = mkVHDLBasicId "n"
 771     n_cur = idToVHDLExpr n_id
 772     -- An expression for previous n
 773     n_prev = n_cur AST.:-: (AST.PrimLit "1")
 774     -- An id for the tmp result vector
 775     tmp_id = mkVHDLBasicId "tmp"
 776     tmp_name = AST.NSimple tmp_id
 777     -- Generate parts of the fold
 778     genFirstCell, genOtherCell :: TranslatorSession (AST.GenerateSm, [CoreSyn.CoreBndr])
 779     genFirstCell = do
 780       let cond_label = mkVHDLExtId "firstcell"
 781       -- if n == 0 or n == len-1
 782       let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
 783       -- Output to tmp[current n]
 784       let resname = mkIndexedName tmp_name n_cur
 785       -- Input from start
 786       argexpr <- MonadState.lift tsType $ varToVHDLExpr start
 787       let startassign = mkUncondAssign (Right resname) argexpr
 788       (app_concsms, used) <- genApplication (Right resname) app_f  [Right argexpr]
 789       -- Return the conditional generate part
 790       let gensm = AST.GenerateSm cond_label cond_scheme [] (if iter then
 791                                                           [startassign]
 792                                                          else
 793                                                           app_concsms
 794                                                         )
 795       return (gensm, used)
 796
 797     genOtherCell = do
 798       let cond_label = mkVHDLExtId "othercell"
 799       -- if n > 0 or n < len-1
 800       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
 801       -- Output to tmp[current n]
 802       let resname = mkIndexedName tmp_name n_cur
 803       -- Input from tmp[previous n]
 804       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
 805       (app_concsms, used) <- genApplication (Right resname) app_f [Right argexpr]
 806       -- Return the conditional generate part
 807       return $ (AST.GenerateSm cond_label cond_scheme [] app_concsms, used)
 808
 809
 810 -----------------------------------------------------------------------------
 811 -- Function to generate VHDL for applications
 812 -----------------------------------------------------------------------------
 813 genApplication ::
 814   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
 815   -> CoreSyn.CoreBndr -- ^ The function to apply
 816   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
 817   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 818   -- ^ The corresponding VHDL concurrent statements and entities
 819   --   instantiated.
 820 genApplication dst f args = do
 821   case Var.isGlobalId f of
 822     False -> do
 823       top <- isTopLevelBinder f
 824       case top of
 825         True -> do
 826           -- Local binder that references a top level binding.  Generate a
 827           -- component instantiation.
 828           signature <- getEntity f
 829           args' <- argsToVHDLExprs args
 830           let entity_id = ent_id signature
 831           -- TODO: Using show here isn't really pretty, but we'll need some
 832           -- unique-ish value...
 833           let label = "comp_ins_" ++ (either show prettyShow) dst
 834           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
 835           return ([mkComponentInst label entity_id portmaps], [f])
 836         False -> do
 837           -- Not a top level binder, so this must be a local variable reference.
 838           -- It should have a representable type (and thus, no arguments) and a
 839           -- signal should be generated for it. Just generate an unconditional
 840           -- assignment here.
 841           f' <- MonadState.lift tsType $ varToVHDLExpr f
 842           return $ ([mkUncondAssign dst f'], [])
 843     True ->
 844       case Var.idDetails f of
 845         IdInfo.DataConWorkId dc -> case dst of
 846           -- It's a datacon. Create a record from its arguments.
 847           Left bndr -> do
 848             -- We have the bndr, so we can get at the type
 849             labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
 850             args' <- argsToVHDLExprs args
 851             return $ (zipWith mkassign labels $ args', [])
 852             where
 853               mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
 854               mkassign label arg =
 855                 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
 856                 mkUncondAssign (Right sel_name) arg
 857           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
 858         IdInfo.DataConWrapId dc -> case dst of
 859           -- It's a datacon. Create a record from its arguments.
 860           Left bndr -> do
 861             case (Map.lookup (varToString f) globalNameTable) of
 862              Just (arg_count, builder) ->
 863               if length args == arg_count then
 864                 builder dst f args
 865               else
 866                 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 867              Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
 868           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
 869         IdInfo.VanillaId -> do
 870           -- It's a global value imported from elsewhere. These can be builtin
 871           -- functions. Look up the function name in the name table and execute
 872           -- the associated builder if there is any and the argument count matches
 873           -- (this should always be the case if it typechecks, but just to be
 874           -- sure...).
 875           case (Map.lookup (varToString f) globalNameTable) of
 876             Just (arg_count, builder) ->
 877               if length args == arg_count then
 878                 builder dst f args
 879               else
 880                 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 881             Nothing -> do
 882               top <- isTopLevelBinder f
 883               case top of
 884                 True -> do
 885                   -- Local binder that references a top level binding.  Generate a
 886                   -- component instantiation.
 887                   signature <- getEntity f
 888                   args' <- argsToVHDLExprs args
 889                   let entity_id = ent_id signature
 890                   -- TODO: Using show here isn't really pretty, but we'll need some
 891                   -- unique-ish value...
 892                   let label = "comp_ins_" ++ (either show prettyShow) dst
 893                   let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
 894                   return ([mkComponentInst label entity_id portmaps], [f])
 895                 False -> do
 896                   -- Not a top level binder, so this must be a local variable reference.
 897                   -- It should have a representable type (and thus, no arguments) and a
 898                   -- signal should be generated for it. Just generate an unconditional
 899                   -- assignment here.
 900                   -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
 901                   -- f' <- MonadState.lift tsType $ varToVHDLExpr f
 902                   --                   return $ ([mkUncondAssign dst f'], [])
 903                   error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
 904         IdInfo.ClassOpId cls -> do
 905           -- FIXME: Not looking for what instance this class op is called for
 906           -- Is quite stupid of course.
 907           case (Map.lookup (varToString f) globalNameTable) of
 908             Just (arg_count, builder) ->
 909               if length args == arg_count then
 910                 builder dst f args
 911               else
 912                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 913             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
 914         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 915
 916 -----------------------------------------------------------------------------
 917 -- Functions to generate functions dealing with vectors.
 918 -----------------------------------------------------------------------------
 919
 920 -- Returns the VHDLId of the vector function with the given name for the given
 921 -- element type. Generates -- this function if needed.
 922 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
 923 vectorFunId el_ty fname = do
 924   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
 925   -- TODO: Handle the Nothing case?
 926   Just elemTM <- vhdl_ty error_msg el_ty
 927   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
 928   -- the VHDLState or something.
 929   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
 930   typefuns <- getA tsTypeFuns
 931   case Map.lookup (OrdType el_ty, fname) typefuns of
 932     -- Function already generated, just return it
 933     Just (id, _) -> return id
 934     -- Function not generated yet, generate it
 935     Nothing -> do
 936       let functions = genUnconsVectorFuns elemTM vectorTM
 937       case lookup fname functions of
 938         Just body -> do
 939           modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
 940           mapM_ (vectorFunId el_ty) (snd body)
 941           return function_id
 942         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
 943   where
 944     function_id = mkVHDLExtId fname
 945
 946 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
 947                     -> AST.TypeMark -- ^ type of the vector
 948                     -> [(String, (AST.SubProgBody, [String]))]
 949 genUnconsVectorFuns elemTM vectorTM  =
 950   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
 951   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
 952   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
 953   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
 954   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
 955   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
 956   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
 957   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
 958   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr],[]))
 959   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
 960   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
 961   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
 962   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
 963   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
 964   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
 965   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
 966   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
 967   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
 968   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
 969   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
 970   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
 971   ]
 972   where
 973     ixPar   = AST.unsafeVHDLBasicId "ix"
 974     vecPar  = AST.unsafeVHDLBasicId "vec"
 975     vec1Par = AST.unsafeVHDLBasicId "vec1"
 976     vec2Par = AST.unsafeVHDLBasicId "vec2"
 977     nPar    = AST.unsafeVHDLBasicId "n"
 978     leftPar = AST.unsafeVHDLBasicId "nLeft"
 979     rightPar = AST.unsafeVHDLBasicId "nRight"
 980     iId     = AST.unsafeVHDLBasicId "i"
 981     iPar    = iId
 982     aPar    = AST.unsafeVHDLBasicId "a"
 983     fPar = AST.unsafeVHDLBasicId "f"
 984     sPar = AST.unsafeVHDLBasicId "s"
 985     resId   = AST.unsafeVHDLBasicId "res"
 986     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
 987                                AST.IfaceVarDec ixPar  naturalTM] elemTM
 988     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
 989               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
 990                 AST.NSimple ixPar]))
 991     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
 992                                           , AST.IfaceVarDec iPar   naturalTM
 993                                           , AST.IfaceVarDec aPar   elemTM
 994                                           ] vectorTM
 995        -- variable res : fsvec_x (0 to vec'length-1);
 996     replaceVar =
 997          AST.VarDec resId
 998                 (AST.SubtypeIn vectorTM
 999                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1000                    [AST.ToRange (AST.PrimLit "0")
1001                             (AST.PrimName (AST.NAttribute $
1002                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1003                                 (AST.PrimLit "1"))   ]))
1004                 Nothing
1005        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1006     replaceExpr = AST.NSimple resId AST.:=
1007            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
1008             AST.PrimName (AST.NSimple aPar) AST.:&:
1009              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
1010                       ((AST.PrimName (AST.NAttribute $
1011                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1012                                                               AST.:-: AST.PrimLit "1"))
1013     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1014     vecSlice init last =  AST.PrimName (AST.NSlice
1015                                         (AST.SliceName
1016                                               (AST.NSimple vecPar)
1017                                               (AST.ToRange init last)))
1018     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1019        -- return vec(vec'length-1);
1020     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1021                     (AST.NSimple vecPar)
1022                     [AST.PrimName (AST.NAttribute $
1023                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1024                                                              AST.:-: AST.PrimLit "1"])))
1025     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1026        -- variable res : fsvec_x (0 to vec'length-2);
1027     initVar =
1028          AST.VarDec resId
1029                 (AST.SubtypeIn vectorTM
1030                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1031                    [AST.ToRange (AST.PrimLit "0")
1032                             (AST.PrimName (AST.NAttribute $
1033                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1034                                 (AST.PrimLit "2"))   ]))
1035                 Nothing
1036        -- resAST.:= vec(0 to vec'length-2)
1037     initExpr = AST.NSimple resId AST.:= (vecSlice
1038                                (AST.PrimLit "0")
1039                                (AST.PrimName (AST.NAttribute $
1040                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1041                                                              AST.:-: AST.PrimLit "2"))
1042     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1043     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
1044                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
1045     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1046                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1047                         []
1048                         (Just $ AST.Else [minimumExprRet])
1049       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1050     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
1051                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1052        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1053     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1054                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1055                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1056                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1057     takeVar =
1058          AST.VarDec resId
1059                 (AST.SubtypeIn vectorTM
1060                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1061                    [AST.ToRange (AST.PrimLit "0")
1062                                (minLength AST.:-:
1063                                 (AST.PrimLit "1"))   ]))
1064                 Nothing
1065        -- res AST.:= vec(0 to n-1)
1066     takeExpr = AST.NSimple resId AST.:=
1067                     (vecSlice (AST.PrimLit "0")
1068                               (minLength AST.:-: AST.PrimLit "1"))
1069     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1070     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
1071                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1072        -- variable res : fsvec_x (0 to vec'length-n-1);
1073     dropVar =
1074          AST.VarDec resId
1075                 (AST.SubtypeIn vectorTM
1076                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1077                    [AST.ToRange (AST.PrimLit "0")
1078                             (AST.PrimName (AST.NAttribute $
1079                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1080                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1081                Nothing
1082        -- res AST.:= vec(n to vec'length-1)
1083     dropExpr = AST.NSimple resId AST.:= (vecSlice
1084                                (AST.PrimName $ AST.NSimple nPar)
1085                                (AST.PrimName (AST.NAttribute $
1086                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1087                                                              AST.:-: AST.PrimLit "1"))
1088     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1089     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
1090                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
1091     -- variable res : fsvec_x (0 to vec'length);
1092     plusgtVar =
1093       AST.VarDec resId
1094              (AST.SubtypeIn vectorTM
1095                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1096                 [AST.ToRange (AST.PrimLit "0")
1097                         (AST.PrimName (AST.NAttribute $
1098                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1099              Nothing
1100     plusgtExpr = AST.NSimple resId AST.:=
1101                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1102                     (AST.PrimName $ AST.NSimple vecPar))
1103     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1104     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1105     emptyVar =
1106           AST.VarDec resId
1107             (AST.SubtypeIn vectorTM
1108               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1109                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1110              Nothing
1111     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1112     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1113                                          vectorTM
1114     -- variable res : fsvec_x (0 to 0) := (others => a);
1115     singletonVar =
1116       AST.VarDec resId
1117              (AST.SubtypeIn vectorTM
1118                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1119                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1120              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1121                                           (AST.PrimName $ AST.NSimple aPar)])
1122     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1123     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1124                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
1125     -- variable res : fsvec_x (0 to n-1) := (others => a);
1126     copynVar =
1127       AST.VarDec resId
1128              (AST.SubtypeIn vectorTM
1129                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1130                 [AST.ToRange (AST.PrimLit "0")
1131                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1132                              (AST.PrimLit "1"))   ]))
1133              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1134                                           (AST.PrimName $ AST.NSimple aPar)])
1135     -- return res
1136     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1137     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1138                                AST.IfaceVarDec sPar   naturalTM,
1139                                AST.IfaceVarDec nPar   naturalTM,
1140                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1141     -- variable res : fsvec_x (0 to n-1);
1142     selVar =
1143       AST.VarDec resId
1144                 (AST.SubtypeIn vectorTM
1145                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1146                     [AST.ToRange (AST.PrimLit "0")
1147                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1148                       (AST.PrimLit "1"))   ])
1149                 )
1150                 Nothing
1151     -- for i res'range loop
1152     --   res(i) := vec(f+i*s);
1153     -- end loop;
1154     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1155     -- res(i) := vec(f+i*s);
1156     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1157                                 (AST.PrimName (AST.NSimple iId) AST.:*:
1158                                   AST.PrimName (AST.NSimple sPar)) in
1159                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1160                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1161     -- return res;
1162     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1163     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1164                                         AST.IfaceVarDec aPar   elemTM] vectorTM
1165      -- variable res : fsvec_x (0 to vec'length);
1166     ltplusVar =
1167       AST.VarDec resId
1168         (AST.SubtypeIn vectorTM
1169           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1170             [AST.ToRange (AST.PrimLit "0")
1171               (AST.PrimName (AST.NAttribute $
1172                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1173         Nothing
1174     ltplusExpr = AST.NSimple resId AST.:=
1175                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1176                       (AST.PrimName $ AST.NSimple aPar))
1177     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1178     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1179                                              AST.IfaceVarDec vec2Par vectorTM]
1180                                              vectorTM
1181     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1182     plusplusVar =
1183       AST.VarDec resId
1184         (AST.SubtypeIn vectorTM
1185           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1186             [AST.ToRange (AST.PrimLit "0")
1187               (AST.PrimName (AST.NAttribute $
1188                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1189                   AST.PrimName (AST.NAttribute $
1190                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1191                   AST.PrimLit "1")]))
1192        Nothing
1193     plusplusExpr = AST.NSimple resId AST.:=
1194                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1195                       (AST.PrimName $ AST.NSimple vec2Par))
1196     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1197     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1198     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1199                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1200     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1201                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM
1202     -- variable res : fsvec_x (0 to vec'length-1);
1203     shiftlVar =
1204      AST.VarDec resId
1205             (AST.SubtypeIn vectorTM
1206               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1207                [AST.ToRange (AST.PrimLit "0")
1208                         (AST.PrimName (AST.NAttribute $
1209                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1210                            (AST.PrimLit "1")) ]))
1211             Nothing
1212     -- res := a & init(vec)
1213     shiftlExpr = AST.NSimple resId AST.:=
1214                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1215                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1216                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1217     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1218     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1219                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM
1220     -- variable res : fsvec_x (0 to vec'length-1);
1221     shiftrVar =
1222      AST.VarDec resId
1223             (AST.SubtypeIn vectorTM
1224               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1225                [AST.ToRange (AST.PrimLit "0")
1226                         (AST.PrimName (AST.NAttribute $
1227                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1228                            (AST.PrimLit "1")) ]))
1229             Nothing
1230     -- res := tail(vec) & a
1231     shiftrExpr = AST.NSimple resId AST.:=
1232                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1233                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1234                   (AST.PrimName (AST.NSimple aPar)))
1235
1236     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1237     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1238     -- return vec'length = 0
1239     nullExpr = AST.ReturnSm (Just $
1240                 AST.PrimName (AST.NAttribute $
1241                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1242                     AST.PrimLit "0")
1243     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1244     -- variable res : fsvec_x (0 to vec'length-1);
1245     rotlVar =
1246      AST.VarDec resId
1247             (AST.SubtypeIn vectorTM
1248               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1249                [AST.ToRange (AST.PrimLit "0")
1250                         (AST.PrimName (AST.NAttribute $
1251                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1252                            (AST.PrimLit "1")) ]))
1253             Nothing
1254     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1255     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1256                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1257                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1258                         []
1259                         (Just $ AST.Else [rotlExprRet])
1260       where rotlExprRet =
1261                 AST.NSimple resId AST.:=
1262                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1263                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1264                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1265                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1266     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1267     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1268     -- variable res : fsvec_x (0 to vec'length-1);
1269     rotrVar =
1270      AST.VarDec resId
1271             (AST.SubtypeIn vectorTM
1272               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1273                [AST.ToRange (AST.PrimLit "0")
1274                         (AST.PrimName (AST.NAttribute $
1275                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1276                            (AST.PrimLit "1")) ]))
1277             Nothing
1278     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1279     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1280                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1281                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1282                         []
1283                         (Just $ AST.Else [rotrExprRet])
1284       where rotrExprRet =
1285                 AST.NSimple resId AST.:=
1286                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1287                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1288                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1289                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1290     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1291     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1292     reverseVar =
1293       AST.VarDec resId
1294              (AST.SubtypeIn vectorTM
1295                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1296                 [AST.ToRange (AST.PrimLit "0")
1297                          (AST.PrimName (AST.NAttribute $
1298                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1299                             (AST.PrimLit "1")) ]))
1300              Nothing
1301     -- for i in 0 to res'range loop
1302     --   res(vec'length-i-1) := vec(i);
1303     -- end loop;
1304     reverseFor =
1305        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1306     -- res(vec'length-i-1) := vec(i);
1307     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1308       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1309                            [AST.PrimName $ AST.NSimple iId]))
1310         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1311                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1312                         AST.PrimName (AST.NSimple iId) AST.:-:
1313                         (AST.PrimLit "1")
1314     -- return res;
1315     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1316
1317
1318 -----------------------------------------------------------------------------
1319 -- A table of builtin functions
1320 -----------------------------------------------------------------------------
1321
1322 -- A function that generates VHDL for a builtin function
1323 type BuiltinBuilder =
1324   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1325   -> CoreSyn.CoreBndr -- ^ The function called
1326   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1327                     --   dictionary arguments).
1328   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1329   -- ^ The corresponding VHDL concurrent statements and entities
1330   --   instantiated.
1331
1332 -- A map of a builtin function to VHDL function builder
1333 type NameTable = Map.Map String (Int, BuiltinBuilder )
1334
1335 -- | The builtin functions we support. Maps a name to an argument count and a
1336 -- builder function.
1337 globalNameTable :: NameTable
1338 globalNameTable = Map.fromList
1339   [ (exId             , (2, genFCall True          ) )
1340   , (replaceId        , (3, genFCall False          ) )
1341   , (headId           , (1, genFCall True           ) )
1342   , (lastId           , (1, genFCall True           ) )
1343   , (tailId           , (1, genFCall False          ) )
1344   , (initId           , (1, genFCall False          ) )
1345   , (takeId           , (2, genFCall False          ) )
1346   , (dropId           , (2, genFCall False          ) )
1347   , (selId            , (4, genFCall False          ) )
1348   , (plusgtId         , (2, genFCall False          ) )
1349   , (ltplusId         , (2, genFCall False          ) )
1350   , (plusplusId       , (2, genFCall False          ) )
1351   , (mapId            , (2, genMap                  ) )
1352   , (zipWithId        , (3, genZipWith              ) )
1353   , (foldlId          , (3, genFoldl                ) )
1354   , (foldrId          , (3, genFoldr                ) )
1355   , (zipId            , (2, genZip                  ) )
1356   , (unzipId          , (1, genUnzip                ) )
1357   , (shiftlId         , (2, genFCall False          ) )
1358   , (shiftrId         , (2, genFCall False          ) )
1359   , (rotlId           , (1, genFCall False          ) )
1360   , (rotrId           , (1, genFCall False          ) )
1361   , (concatId         , (1, genConcat               ) )
1362   , (reverseId        , (1, genFCall False          ) )
1363   , (iteratenId       , (3, genIteraten             ) )
1364   , (iterateId        , (2, genIterate              ) )
1365   , (generatenId      , (3, genGeneraten            ) )
1366   , (generateId       , (2, genGenerate             ) )
1367   , (emptyId          , (0, genFCall False          ) )
1368   , (singletonId      , (1, genFCall False          ) )
1369   , (copynId          , (2, genFCall False          ) )
1370   , (copyId           , (1, genCopy                 ) )
1371   , (lengthTId        , (1, genFCall False          ) )
1372   , (nullId           , (1, genFCall False          ) )
1373   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1374   , (hwandId          , (2, genOperator2 AST.And    ) )
1375   , (hworId           , (2, genOperator2 AST.Or     ) )
1376   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1377   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1378   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
1379   , (negateId         , (1, genNegation             ) )
1380   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1381   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1382   , (fromIntegerId    , (1, genFromInteger          ) )
1383   , (resizeId         , (1, genResize               ) )
1384   , (sizedIntId       , (1, genSizedInt             ) )
1385   , (smallIntegerId   , (1, genFromInteger          ) )
1386   --, (tfvecId          , (1, genTFVec                ) )
1387   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
1388   ]