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