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