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