cλash/CLasH/VHDL/Generate.hs

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