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