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