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