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