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