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(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 842             Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
 843         IdInfo.ClassOpId cls -> do
 844           -- FIXME: Not looking for what instance this class op is called for
 845           -- Is quite stupid of course.
 846           case (Map.lookup (varToString f) globalNameTable) of
 847             Just (arg_count, builder) ->
 848               if length args == arg_count then
 849                 builder dst f args
 850               else
 851                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 852             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
 853         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 854     -- If we can't generate a component instantiation, and the destination is
 855     -- a state type, don't generate anything.
 856     _ -> return ([], [])
 857   where
 858     -- Is our destination a state value?
 859     stateful = case dst of
 860       -- When our destination is a VHDL name, it won't have had a state type
 861       Right _ -> False
 862       -- Otherwise check its type
 863       Left bndr -> hasStateType bndr
 864
 865 -----------------------------------------------------------------------------
 866 -- Functions to generate functions dealing with vectors.
 867 -----------------------------------------------------------------------------
 868
 869 -- Returns the VHDLId of the vector function with the given name for the given
 870 -- element type. Generates -- this function if needed.
 871 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
 872 vectorFunId el_ty fname = do
 873   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
 874   -- TODO: Handle the Nothing case?
 875   Just elemTM <- vhdl_ty error_msg el_ty
 876   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
 877   -- the VHDLState or something.
 878   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
 879   typefuns <- getA tsTypeFuns
 880   case Map.lookup (OrdType el_ty, fname) typefuns of
 881     -- Function already generated, just return it
 882     Just (id, _) -> return id
 883     -- Function not generated yet, generate it
 884     Nothing -> do
 885       let functions = genUnconsVectorFuns elemTM vectorTM
 886       case lookup fname functions of
 887         Just body -> do
 888           modA tsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
 889           mapM_ (vectorFunId el_ty) (snd body)
 890           return function_id
 891         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
 892   where
 893     function_id = mkVHDLExtId fname
 894
 895 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
 896                     -> AST.TypeMark -- ^ type of the vector
 897                     -> [(String, (AST.SubProgBody, [String]))]
 898 genUnconsVectorFuns elemTM vectorTM  =
 899   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
 900   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
 901   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
 902   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
 903   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
 904   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
 905   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
 906   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
 907   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
 908   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
 909   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
 910   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
 911   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
 912   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
 913   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
 914   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
 915   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
 916   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
 917   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
 918   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
 919   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
 920   ]
 921   where
 922     ixPar   = AST.unsafeVHDLBasicId "ix"
 923     vecPar  = AST.unsafeVHDLBasicId "vec"
 924     vec1Par = AST.unsafeVHDLBasicId "vec1"
 925     vec2Par = AST.unsafeVHDLBasicId "vec2"
 926     nPar    = AST.unsafeVHDLBasicId "n"
 927     leftPar = AST.unsafeVHDLBasicId "nLeft"
 928     rightPar = AST.unsafeVHDLBasicId "nRight"
 929     iId     = AST.unsafeVHDLBasicId "i"
 930     iPar    = iId
 931     aPar    = AST.unsafeVHDLBasicId "a"
 932     fPar = AST.unsafeVHDLBasicId "f"
 933     sPar = AST.unsafeVHDLBasicId "s"
 934     resId   = AST.unsafeVHDLBasicId "res"
 935     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
 936                                AST.IfaceVarDec ixPar  naturalTM] elemTM
 937     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
 938               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
 939                 AST.NSimple ixPar]))
 940     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
 941                                           , AST.IfaceVarDec iPar   naturalTM
 942                                           , AST.IfaceVarDec aPar   elemTM
 943                                           ] vectorTM
 944        -- variable res : fsvec_x (0 to vec'length-1);
 945     replaceVar =
 946          AST.VarDec resId
 947                 (AST.SubtypeIn vectorTM
 948                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 949                    [AST.ToRange (AST.PrimLit "0")
 950                             (AST.PrimName (AST.NAttribute $
 951                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 952                                 (AST.PrimLit "1"))   ]))
 953                 Nothing
 954        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
 955     replaceExpr = AST.NSimple resId AST.:=
 956            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
 957             AST.PrimName (AST.NSimple aPar) AST.:&:
 958              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
 959                       ((AST.PrimName (AST.NAttribute $
 960                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 961                                                               AST.:-: AST.PrimLit "1"))
 962     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 963     vecSlice init last =  AST.PrimName (AST.NSlice
 964                                         (AST.SliceName
 965                                               (AST.NSimple vecPar)
 966                                               (AST.ToRange init last)))
 967     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 968        -- return vec(vec'length-1);
 969     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 970                     (AST.NSimple vecPar)
 971                     [AST.PrimName (AST.NAttribute $
 972                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 973                                                              AST.:-: AST.PrimLit "1"])))
 974     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 975        -- variable res : fsvec_x (0 to vec'length-2);
 976     initVar =
 977          AST.VarDec resId
 978                 (AST.SubtypeIn vectorTM
 979                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 980                    [AST.ToRange (AST.PrimLit "0")
 981                             (AST.PrimName (AST.NAttribute $
 982                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 983                                 (AST.PrimLit "2"))   ]))
 984                 Nothing
 985        -- resAST.:= vec(0 to vec'length-2)
 986     initExpr = AST.NSimple resId AST.:= (vecSlice
 987                                (AST.PrimLit "0")
 988                                (AST.PrimName (AST.NAttribute $
 989                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 990                                                              AST.:-: AST.PrimLit "2"))
 991     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 992     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
 993                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
 994     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
 995                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
 996                         []
 997                         (Just $ AST.Else [minimumExprRet])
 998       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
 999     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
1000                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1001        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1002     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1003                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1004                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1005                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1006     takeVar =
1007          AST.VarDec resId
1008                 (AST.SubtypeIn vectorTM
1009                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1010                    [AST.ToRange (AST.PrimLit "0")
1011                                (minLength AST.:-:
1012                                 (AST.PrimLit "1"))   ]))
1013                 Nothing
1014        -- res AST.:= vec(0 to n-1)
1015     takeExpr = AST.NSimple resId AST.:=
1016                     (vecSlice (AST.PrimLit "0")
1017                               (minLength AST.:-: AST.PrimLit "1"))
1018     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1019     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
1020                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1021        -- variable res : fsvec_x (0 to vec'length-n-1);
1022     dropVar =
1023          AST.VarDec resId
1024                 (AST.SubtypeIn vectorTM
1025                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1026                    [AST.ToRange (AST.PrimLit "0")
1027                             (AST.PrimName (AST.NAttribute $
1028                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1029                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1030                Nothing
1031        -- res AST.:= vec(n to vec'length-1)
1032     dropExpr = AST.NSimple resId AST.:= (vecSlice
1033                                (AST.PrimName $ AST.NSimple nPar)
1034                                (AST.PrimName (AST.NAttribute $
1035                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1036                                                              AST.:-: AST.PrimLit "1"))
1037     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1038     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
1039                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
1040     -- variable res : fsvec_x (0 to vec'length);
1041     plusgtVar =
1042       AST.VarDec resId
1043              (AST.SubtypeIn vectorTM
1044                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1045                 [AST.ToRange (AST.PrimLit "0")
1046                         (AST.PrimName (AST.NAttribute $
1047                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1048              Nothing
1049     plusgtExpr = AST.NSimple resId AST.:=
1050                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1051                     (AST.PrimName $ AST.NSimple vecPar))
1052     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1053     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1054     emptyVar =
1055           AST.ConstDec resId
1056               (AST.SubtypeIn vectorTM Nothing)
1057               (Just $ AST.PrimLit "\"\"")
1058     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1059     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1060                                          vectorTM
1061     -- variable res : fsvec_x (0 to 0) := (others => a);
1062     singletonVar =
1063       AST.VarDec resId
1064              (AST.SubtypeIn vectorTM
1065                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1066                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1067              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1068                                           (AST.PrimName $ AST.NSimple aPar)])
1069     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1070     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1071                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
1072     -- variable res : fsvec_x (0 to n-1) := (others => a);
1073     copynVar =
1074       AST.VarDec resId
1075              (AST.SubtypeIn vectorTM
1076                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1077                 [AST.ToRange (AST.PrimLit "0")
1078                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1079                              (AST.PrimLit "1"))   ]))
1080              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1081                                           (AST.PrimName $ AST.NSimple aPar)])
1082     -- return res
1083     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1084     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1085                                AST.IfaceVarDec sPar   naturalTM,
1086                                AST.IfaceVarDec nPar   naturalTM,
1087                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1088     -- variable res : fsvec_x (0 to n-1);
1089     selVar =
1090       AST.VarDec resId
1091                 (AST.SubtypeIn vectorTM
1092                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1093                     [AST.ToRange (AST.PrimLit "0")
1094                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1095                       (AST.PrimLit "1"))   ])
1096                 )
1097                 Nothing
1098     -- for i res'range loop
1099     --   res(i) := vec(f+i*s);
1100     -- end loop;
1101     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1102     -- res(i) := vec(f+i*s);
1103     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1104                                 (AST.PrimName (AST.NSimple iId) AST.:*:
1105                                   AST.PrimName (AST.NSimple sPar)) in
1106                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1107                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1108     -- return res;
1109     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1110     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1111                                         AST.IfaceVarDec aPar   elemTM] vectorTM
1112      -- variable res : fsvec_x (0 to vec'length);
1113     ltplusVar =
1114       AST.VarDec resId
1115         (AST.SubtypeIn vectorTM
1116           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1117             [AST.ToRange (AST.PrimLit "0")
1118               (AST.PrimName (AST.NAttribute $
1119                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1120         Nothing
1121     ltplusExpr = AST.NSimple resId AST.:=
1122                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1123                       (AST.PrimName $ AST.NSimple aPar))
1124     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1125     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1126                                              AST.IfaceVarDec vec2Par vectorTM]
1127                                              vectorTM
1128     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1129     plusplusVar =
1130       AST.VarDec resId
1131         (AST.SubtypeIn vectorTM
1132           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1133             [AST.ToRange (AST.PrimLit "0")
1134               (AST.PrimName (AST.NAttribute $
1135                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1136                   AST.PrimName (AST.NAttribute $
1137                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1138                   AST.PrimLit "1")]))
1139        Nothing
1140     plusplusExpr = AST.NSimple resId AST.:=
1141                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1142                       (AST.PrimName $ AST.NSimple vec2Par))
1143     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1144     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1145     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1146                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1147     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1148                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM
1149     -- variable res : fsvec_x (0 to vec'length-1);
1150     shiftlVar =
1151      AST.VarDec resId
1152             (AST.SubtypeIn vectorTM
1153               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1154                [AST.ToRange (AST.PrimLit "0")
1155                         (AST.PrimName (AST.NAttribute $
1156                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1157                            (AST.PrimLit "1")) ]))
1158             Nothing
1159     -- res := a & init(vec)
1160     shiftlExpr = AST.NSimple resId AST.:=
1161                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1162                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1163                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1164     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1165     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1166                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM
1167     -- variable res : fsvec_x (0 to vec'length-1);
1168     shiftrVar =
1169      AST.VarDec resId
1170             (AST.SubtypeIn vectorTM
1171               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1172                [AST.ToRange (AST.PrimLit "0")
1173                         (AST.PrimName (AST.NAttribute $
1174                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1175                            (AST.PrimLit "1")) ]))
1176             Nothing
1177     -- res := tail(vec) & a
1178     shiftrExpr = AST.NSimple resId AST.:=
1179                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1180                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1181                   (AST.PrimName (AST.NSimple aPar)))
1182
1183     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1184     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1185     -- return vec'length = 0
1186     nullExpr = AST.ReturnSm (Just $
1187                 AST.PrimName (AST.NAttribute $
1188                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1189                     AST.PrimLit "0")
1190     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1191     -- variable res : fsvec_x (0 to vec'length-1);
1192     rotlVar =
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     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1202     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1203                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1204                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1205                         []
1206                         (Just $ AST.Else [rotlExprRet])
1207       where rotlExprRet =
1208                 AST.NSimple resId AST.:=
1209                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1210                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1211                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1212                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1213     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1214     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1215     -- variable res : fsvec_x (0 to vec'length-1);
1216     rotrVar =
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 := tail(vec) & head(vec)
1226     rotrExpr = 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 [rotrExprRet])
1231       where rotrExprRet =
1232                 AST.NSimple resId AST.:=
1233                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1234                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1235                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1236                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1237     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1238     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1239     reverseVar =
1240       AST.VarDec resId
1241              (AST.SubtypeIn vectorTM
1242                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1243                 [AST.ToRange (AST.PrimLit "0")
1244                          (AST.PrimName (AST.NAttribute $
1245                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1246                             (AST.PrimLit "1")) ]))
1247              Nothing
1248     -- for i in 0 to res'range loop
1249     --   res(vec'length-i-1) := vec(i);
1250     -- end loop;
1251     reverseFor =
1252        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1253     -- res(vec'length-i-1) := vec(i);
1254     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1255       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1256                            [AST.PrimName $ AST.NSimple iId]))
1257         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1258                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1259                         AST.PrimName (AST.NSimple iId) AST.:-:
1260                         (AST.PrimLit "1")
1261     -- return res;
1262     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1263
1264
1265 -----------------------------------------------------------------------------
1266 -- A table of builtin functions
1267 -----------------------------------------------------------------------------
1268
1269 -- A function that generates VHDL for a builtin function
1270 type BuiltinBuilder =
1271   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1272   -> CoreSyn.CoreBndr -- ^ The function called
1273   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1274                     --   dictionary arguments).
1275   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1276   -- ^ The corresponding VHDL concurrent statements and entities
1277   --   instantiated.
1278
1279 -- A map of a builtin function to VHDL function builder
1280 type NameTable = Map.Map String (Int, BuiltinBuilder )
1281
1282 -- | The builtin functions we support. Maps a name to an argument count and a
1283 -- builder function.
1284 globalNameTable :: NameTable
1285 globalNameTable = Map.fromList
1286   [ (exId             , (2, genFCall True          ) )
1287   , (replaceId        , (3, genFCall False          ) )
1288   , (headId           , (1, genFCall True           ) )
1289   , (lastId           , (1, genFCall True           ) )
1290   , (tailId           , (1, genFCall False          ) )
1291   , (initId           , (1, genFCall False          ) )
1292   , (takeId           , (2, genFCall False          ) )
1293   , (dropId           , (2, genFCall False          ) )
1294   , (selId            , (4, genFCall False          ) )
1295   , (plusgtId         , (2, genFCall False          ) )
1296   , (ltplusId         , (2, genFCall False          ) )
1297   , (plusplusId       , (2, genFCall False          ) )
1298   , (mapId            , (2, genMap                  ) )
1299   , (zipWithId        , (3, genZipWith              ) )
1300   , (foldlId          , (3, genFoldl                ) )
1301   , (foldrId          , (3, genFoldr                ) )
1302   , (zipId            , (2, genZip                  ) )
1303   , (unzipId          , (1, genUnzip                ) )
1304   , (shiftlId         , (2, genFCall False          ) )
1305   , (shiftrId         , (2, genFCall False          ) )
1306   , (rotlId           , (1, genFCall False          ) )
1307   , (rotrId           , (1, genFCall False          ) )
1308   , (concatId         , (1, genConcat               ) )
1309   , (reverseId        , (1, genFCall False          ) )
1310   , (iteratenId       , (3, genIteraten             ) )
1311   , (iterateId        , (2, genIterate              ) )
1312   , (generatenId      , (3, genGeneraten            ) )
1313   , (generateId       , (2, genGenerate             ) )
1314   , (emptyId          , (0, genFCall False          ) )
1315   , (singletonId      , (1, genFCall False          ) )
1316   , (copynId          , (2, genFCall False          ) )
1317   , (copyId           , (1, genCopy                 ) )
1318   , (lengthTId        , (1, genFCall False          ) )
1319   , (nullId           , (1, genFCall False          ) )
1320   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1321   , (hwandId          , (2, genOperator2 AST.And    ) )
1322   , (hworId           , (2, genOperator2 AST.Or     ) )
1323   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1324   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1325   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
1326   , (negateId         , (1, genNegation             ) )
1327   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1328   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1329   , (fromIntegerId    , (1, genFromInteger          ) )
1330   , (resizeId         , (1, genResize               ) )
1331   , (sizedIntId       , (1, genSizedInt             ) )
1332   --, (tfvecId          , (1, genTFVec                ) )
1333   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
1334   ]