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