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