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