cλash/CLasH/VHDL/Generate.hs

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