cλash/CLasH/VHDL/Generate.hs

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