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