cλash/CLasH/VHDL/Generate.hs

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