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