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 not 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 genSplit :: BuiltinBuilder
 898 genSplit = genNoInsts $ genVarArgs genSplit'
 899
 900 genSplit' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> TranslatorSession [AST.ConcSm]
 901 genSplit' (Left res) f args@[vecIn] = do {
 902   ; labels <- MonadState.lift tsType $ getFieldLabels (Var.varType res)
 903   ; len <- MonadState.lift tsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vecIn
 904   ; let { block_label = mkVHDLExtId ("split" ++ (varToString vecIn))
 905         ; halflen   = round ((fromIntegral len) / 2)
 906         ; rangeL    = vecSlice (AST.PrimLit "0") (AST.PrimLit $ show (halflen - 1))
 907         ; rangeR    = vecSlice (AST.PrimLit $ show halflen) (AST.PrimLit $ show (len - 1))
 908         ; resname   = varToVHDLName res
 909         ; resnameL  = mkSelectedName resname (labels!!0)
 910         ; resnameR  = mkSelectedName resname (labels!!1)
 911         ; argexprL  = vhdlNameToVHDLExpr rangeL
 912         ; argexprR  = vhdlNameToVHDLExpr rangeR
 913         ; out_assignL = mkUncondAssign (Right resnameL) argexprL
 914         ; out_assignR = mkUncondAssign (Right resnameR) argexprR
 915         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [out_assignL, out_assignR]
 916         }
 917   ; return [AST.CSBSm block]
 918   }
 919   where
 920     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res)
 921                             (AST.ToRange init last))
 922 -----------------------------------------------------------------------------
 923 -- Function to generate VHDL for applications
 924 -----------------------------------------------------------------------------
 925 genApplication ::
 926   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
 927   -> CoreSyn.CoreBndr -- ^ The function to apply
 928   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
 929   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
 930   -- ^ The corresponding VHDL concurrent statements and entities
 931   --   instantiated.
 932 genApplication dst f args = do
 933   case Var.isGlobalId f of
 934     False -> do
 935       top <- isTopLevelBinder f
 936       case top of
 937         True -> do
 938           -- Local binder that references a top level binding.  Generate a
 939           -- component instantiation.
 940           signature <- getEntity f
 941           args' <- argsToVHDLExprs args
 942           let entity_id = ent_id signature
 943           -- TODO: Using show here isn't really pretty, but we'll need some
 944           -- unique-ish value...
 945           let label = "comp_ins_" ++ (either (prettyShow . varToVHDLName) prettyShow) dst
 946           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
 947           return ([mkComponentInst label entity_id portmaps], [f])
 948         False -> do
 949           -- Not a top level binder, so this must be a local variable reference.
 950           -- It should have a representable type (and thus, no arguments) and a
 951           -- signal should be generated for it. Just generate an unconditional
 952           -- assignment here.
 953           f' <- MonadState.lift tsType $ varToVHDLExpr f
 954           return $ ([mkUncondAssign dst f'], [])
 955     True ->
 956       case Var.idDetails f of
 957         IdInfo.DataConWorkId dc -> case dst of
 958           -- It's a datacon. Create a record from its arguments.
 959           Left bndr -> do
 960             -- We have the bndr, so we can get at the type
 961             labels <- MonadState.lift tsType $ getFieldLabels (Var.varType bndr)
 962             args' <- argsToVHDLExprs args
 963             return $ (zipWith mkassign labels $ args', [])
 964             where
 965               mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
 966               mkassign label arg =
 967                 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
 968                 mkUncondAssign (Right sel_name) arg
 969           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
 970         IdInfo.DataConWrapId dc -> case dst of
 971           -- It's a datacon. Create a record from its arguments.
 972           Left bndr -> do
 973             case (Map.lookup (varToString f) globalNameTable) of
 974              Just (arg_count, builder) ->
 975               if length args == arg_count then
 976                 builder dst f args
 977               else
 978                 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 979              Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
 980           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
 981         IdInfo.VanillaId -> do
 982           -- It's a global value imported from elsewhere. These can be builtin
 983           -- functions. Look up the function name in the name table and execute
 984           -- the associated builder if there is any and the argument count matches
 985           -- (this should always be the case if it typechecks, but just to be
 986           -- sure...).
 987           case (Map.lookup (varToString f) globalNameTable) of
 988             Just (arg_count, builder) ->
 989               if length args == arg_count then
 990                 builder dst f args
 991               else
 992                 error $ "\nGenerate.genApplication(VanillaId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 993             Nothing -> do
 994               top <- isTopLevelBinder f
 995               case top of
 996                 True -> do
 997                   -- Local binder that references a top level binding.  Generate a
 998                   -- component instantiation.
 999                   signature <- getEntity f
1000                   args' <- argsToVHDLExprs args
1001                   let entity_id = ent_id signature
1002                   -- TODO: Using show here isn't really pretty, but we'll need some
1003                   -- unique-ish value...
1004                   let label = "comp_ins_" ++ (either show prettyShow) dst
1005                   let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
1006                   return ([mkComponentInst label entity_id portmaps], [f])
1007                 False -> do
1008                   -- Not a top level binder, so this must be a local variable reference.
1009                   -- It should have a representable type (and thus, no arguments) and a
1010                   -- signal should be generated for it. Just generate an unconditional
1011                   -- assignment here.
1012                   -- FIXME : I DONT KNOW IF THE ABOVE COMMENT HOLDS HERE, SO FOR NOW JUST ERROR!
1013                   -- f' <- MonadState.lift tsType $ varToVHDLExpr f
1014                   --                   return $ ([mkUncondAssign dst f'], [])
1015                   error $ ("\nGenerate.genApplication(VanillaId): Using function from another module that is not a known builtin: " ++ (pprString f))
1016         IdInfo.ClassOpId cls -> do
1017           -- FIXME: Not looking for what instance this class op is called for
1018           -- Is quite stupid of course.
1019           case (Map.lookup (varToString f) globalNameTable) of
1020             Just (arg_count, builder) ->
1021               if length args == arg_count then
1022                 builder dst f args
1023               else
1024                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
1025             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
1026         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
1027
1028 -----------------------------------------------------------------------------
1029 -- Functions to generate functions dealing with vectors.
1030 -----------------------------------------------------------------------------
1031
1032 -- Returns the VHDLId of the vector function with the given name for the given
1033 -- element type. Generates -- this function if needed.
1034 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
1035 vectorFunId el_ty fname = do
1036   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
1037   -- TODO: Handle the Nothing case?
1038   Just elemTM <- vhdl_ty error_msg el_ty
1039   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
1040   -- the VHDLState or something.
1041   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
1042   typefuns <- getA tsTypeFuns
1043   case Map.lookup (StdType $ OrdType el_ty, fname) typefuns of
1044     -- Function already generated, just return it
1045     Just (id, _) -> return id
1046     -- Function not generated yet, generate it
1047     Nothing -> do
1048       let functions = genUnconsVectorFuns elemTM vectorTM
1049       case lookup fname functions of
1050         Just body -> do
1051           modA tsTypeFuns $ Map.insert (StdType $ OrdType el_ty, fname) (function_id, (fst body))
1052           mapM_ (vectorFunId el_ty) (snd body)
1053           return function_id
1054         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
1055   where
1056     function_id = mkVHDLExtId fname
1057
1058 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
1059                     -> AST.TypeMark -- ^ type of the vector
1060                     -> [(String, (AST.SubProgBody, [String]))]
1061 genUnconsVectorFuns elemTM vectorTM  =
1062   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
1063   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr1,replaceExpr2,replaceRet],[]))
1064   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
1065   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
1066   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
1067   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
1068   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
1069   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
1070   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPVD emptyVar] [emptyExpr],[]))
1071   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
1072   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
1073   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
1074   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
1075   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
1076   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
1077   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
1078   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
1079   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
1080   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
1081   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
1082   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
1083   ]
1084   where
1085     ixPar   = AST.unsafeVHDLBasicId "ix"
1086     vecPar  = AST.unsafeVHDLBasicId "vec"
1087     vec1Par = AST.unsafeVHDLBasicId "vec1"
1088     vec2Par = AST.unsafeVHDLBasicId "vec2"
1089     nPar    = AST.unsafeVHDLBasicId "n"
1090     leftPar = AST.unsafeVHDLBasicId "nLeft"
1091     rightPar = AST.unsafeVHDLBasicId "nRight"
1092     iId     = AST.unsafeVHDLBasicId "i"
1093     iPar    = iId
1094     aPar    = AST.unsafeVHDLBasicId "a"
1095     fPar = AST.unsafeVHDLBasicId "f"
1096     sPar = AST.unsafeVHDLBasicId "s"
1097     resId   = AST.unsafeVHDLBasicId "res"
1098     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
1099                                AST.IfaceVarDec ixPar  unsignedTM] elemTM
1100     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
1101               (AST.IndexedName (AST.NSimple vecPar) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ ixPar)]))
1102     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
1103                                           , AST.IfaceVarDec iPar   unsignedTM
1104                                           , AST.IfaceVarDec aPar   elemTM
1105                                           ] vectorTM
1106        -- variable res : fsvec_x (0 to vec'length-1);
1107     replaceVar =
1108          AST.VarDec resId
1109                 (AST.SubtypeIn vectorTM
1110                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1111                    [AST.ToRange (AST.PrimLit "0")
1112                             (AST.PrimName (AST.NAttribute $
1113                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1114                                 (AST.PrimLit "1"))   ]))
1115                 Nothing
1116        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
1117     replaceExpr1 = AST.NSimple resId AST.:= AST.PrimName (AST.NSimple vecPar)
1118     replaceExpr2 = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [genExprFCall (mkVHDLBasicId toIntegerId) (AST.PrimName $ AST.NSimple $ iPar)]) AST.:= AST.PrimName (AST.NSimple aPar)
1119     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1120     vecSlice init last =  AST.PrimName (AST.NSlice
1121                                         (AST.SliceName
1122                                               (AST.NSimple vecPar)
1123                                               (AST.ToRange init last)))
1124     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
1125        -- return vec(vec'length-1);
1126     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
1127                     (AST.NSimple vecPar)
1128                     [AST.PrimName (AST.NAttribute $
1129                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1130                                                              AST.:-: AST.PrimLit "1"])))
1131     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1132        -- variable res : fsvec_x (0 to vec'length-2);
1133     initVar =
1134          AST.VarDec resId
1135                 (AST.SubtypeIn vectorTM
1136                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1137                    [AST.ToRange (AST.PrimLit "0")
1138                             (AST.PrimName (AST.NAttribute $
1139                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1140                                 (AST.PrimLit "2"))   ]))
1141                 Nothing
1142        -- resAST.:= vec(0 to vec'length-2)
1143     initExpr = AST.NSimple resId AST.:= (vecSlice
1144                                (AST.PrimLit "0")
1145                                (AST.PrimName (AST.NAttribute $
1146                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1147                                                              AST.:-: AST.PrimLit "2"))
1148     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1149     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
1150                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
1151     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
1152                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
1153                         []
1154                         (Just $ AST.Else [minimumExprRet])
1155       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
1156     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
1157                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1158        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
1159     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
1160                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
1161                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
1162                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
1163     takeVar =
1164          AST.VarDec resId
1165                 (AST.SubtypeIn vectorTM
1166                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1167                    [AST.ToRange (AST.PrimLit "0")
1168                                (minLength AST.:-:
1169                                 (AST.PrimLit "1"))   ]))
1170                 Nothing
1171        -- res AST.:= vec(0 to n-1)
1172     takeExpr = AST.NSimple resId AST.:=
1173                     (vecSlice (AST.PrimLit "0")
1174                               (minLength AST.:-: AST.PrimLit "1"))
1175     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1176     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
1177                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
1178        -- variable res : fsvec_x (0 to vec'length-n-1);
1179     dropVar =
1180          AST.VarDec resId
1181                 (AST.SubtypeIn vectorTM
1182                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1183                    [AST.ToRange (AST.PrimLit "0")
1184                             (AST.PrimName (AST.NAttribute $
1185                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1186                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
1187                Nothing
1188        -- res AST.:= vec(n to vec'length-1)
1189     dropExpr = AST.NSimple resId AST.:= (vecSlice
1190                                (AST.PrimName $ AST.NSimple nPar)
1191                                (AST.PrimName (AST.NAttribute $
1192                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
1193                                                              AST.:-: AST.PrimLit "1"))
1194     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1195     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
1196                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
1197     -- variable res : fsvec_x (0 to vec'length);
1198     plusgtVar =
1199       AST.VarDec resId
1200              (AST.SubtypeIn vectorTM
1201                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1202                 [AST.ToRange (AST.PrimLit "0")
1203                         (AST.PrimName (AST.NAttribute $
1204                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1205              Nothing
1206     plusgtExpr = AST.NSimple resId AST.:=
1207                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
1208                     (AST.PrimName $ AST.NSimple vecPar))
1209     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1210     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
1211     emptyVar =
1212           AST.VarDec resId
1213             (AST.SubtypeIn vectorTM
1214               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1215                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "-1")]))
1216              Nothing
1217     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1218     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
1219                                          vectorTM
1220     -- variable res : fsvec_x (0 to 0) := (others => a);
1221     singletonVar =
1222       AST.VarDec resId
1223              (AST.SubtypeIn vectorTM
1224                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1225                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
1226              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1227                                           (AST.PrimName $ AST.NSimple aPar)])
1228     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1229     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
1230                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
1231     -- variable res : fsvec_x (0 to n-1) := (others => a);
1232     copynVar =
1233       AST.VarDec resId
1234              (AST.SubtypeIn vectorTM
1235                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1236                 [AST.ToRange (AST.PrimLit "0")
1237                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1238                              (AST.PrimLit "1"))   ]))
1239              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
1240                                           (AST.PrimName $ AST.NSimple aPar)])
1241     -- return res
1242     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1243     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
1244                                AST.IfaceVarDec sPar   naturalTM,
1245                                AST.IfaceVarDec nPar   naturalTM,
1246                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
1247     -- variable res : fsvec_x (0 to n-1);
1248     selVar =
1249       AST.VarDec resId
1250                 (AST.SubtypeIn vectorTM
1251                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1252                     [AST.ToRange (AST.PrimLit "0")
1253                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
1254                       (AST.PrimLit "1"))   ])
1255                 )
1256                 Nothing
1257     -- for i res'range loop
1258     --   res(i) := vec(f+i*s);
1259     -- end loop;
1260     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
1261     -- res(i) := vec(f+i*s);
1262     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
1263                                 (AST.PrimName (AST.NSimple iId) AST.:*:
1264                                   AST.PrimName (AST.NSimple sPar)) in
1265                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
1266                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
1267     -- return res;
1268     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1269     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
1270                                         AST.IfaceVarDec aPar   elemTM] vectorTM
1271      -- variable res : fsvec_x (0 to vec'length);
1272     ltplusVar =
1273       AST.VarDec resId
1274         (AST.SubtypeIn vectorTM
1275           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1276             [AST.ToRange (AST.PrimLit "0")
1277               (AST.PrimName (AST.NAttribute $
1278                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
1279         Nothing
1280     ltplusExpr = AST.NSimple resId AST.:=
1281                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
1282                       (AST.PrimName $ AST.NSimple aPar))
1283     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1284     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
1285                                              AST.IfaceVarDec vec2Par vectorTM]
1286                                              vectorTM
1287     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
1288     plusplusVar =
1289       AST.VarDec resId
1290         (AST.SubtypeIn vectorTM
1291           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1292             [AST.ToRange (AST.PrimLit "0")
1293               (AST.PrimName (AST.NAttribute $
1294                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
1295                   AST.PrimName (AST.NAttribute $
1296                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1297                   AST.PrimLit "1")]))
1298        Nothing
1299     plusplusExpr = AST.NSimple resId AST.:=
1300                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
1301                       (AST.PrimName $ AST.NSimple vec2Par))
1302     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1303     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
1304     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
1305                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
1306     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
1307                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM
1308     -- variable res : fsvec_x (0 to vec'length-1);
1309     shiftlVar =
1310      AST.VarDec resId
1311             (AST.SubtypeIn vectorTM
1312               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1313                [AST.ToRange (AST.PrimLit "0")
1314                         (AST.PrimName (AST.NAttribute $
1315                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1316                            (AST.PrimLit "1")) ]))
1317             Nothing
1318     -- res := a & init(vec)
1319     shiftlExpr = AST.NSimple resId AST.:=
1320                     (AST.PrimName (AST.NSimple aPar) AST.:&:
1321                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1322                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1323     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1324     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
1325                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM
1326     -- variable res : fsvec_x (0 to vec'length-1);
1327     shiftrVar =
1328      AST.VarDec resId
1329             (AST.SubtypeIn vectorTM
1330               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1331                [AST.ToRange (AST.PrimLit "0")
1332                         (AST.PrimName (AST.NAttribute $
1333                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1334                            (AST.PrimLit "1")) ]))
1335             Nothing
1336     -- res := tail(vec) & a
1337     shiftrExpr = AST.NSimple resId AST.:=
1338                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1339                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1340                   (AST.PrimName (AST.NSimple aPar)))
1341
1342     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1343     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
1344     -- return vec'length = 0
1345     nullExpr = AST.ReturnSm (Just $
1346                 AST.PrimName (AST.NAttribute $
1347                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
1348                     AST.PrimLit "0")
1349     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1350     -- variable res : fsvec_x (0 to vec'length-1);
1351     rotlVar =
1352      AST.VarDec resId
1353             (AST.SubtypeIn vectorTM
1354               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1355                [AST.ToRange (AST.PrimLit "0")
1356                         (AST.PrimName (AST.NAttribute $
1357                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1358                            (AST.PrimLit "1")) ]))
1359             Nothing
1360     -- if null(vec) then res := vec else res := last(vec) & init(vec)
1361     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1362                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1363                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1364                         []
1365                         (Just $ AST.Else [rotlExprRet])
1366       where rotlExprRet =
1367                 AST.NSimple resId AST.:=
1368                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1369                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1370                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1371                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1372     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1373     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1374     -- variable res : fsvec_x (0 to vec'length-1);
1375     rotrVar =
1376      AST.VarDec resId
1377             (AST.SubtypeIn vectorTM
1378               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1379                [AST.ToRange (AST.PrimLit "0")
1380                         (AST.PrimName (AST.NAttribute $
1381                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1382                            (AST.PrimLit "1")) ]))
1383             Nothing
1384     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1385     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1386                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1387                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1388                         []
1389                         (Just $ AST.Else [rotrExprRet])
1390       where rotrExprRet =
1391                 AST.NSimple resId AST.:=
1392                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1393                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1394                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1395                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1396     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1397     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1398     reverseVar =
1399       AST.VarDec resId
1400              (AST.SubtypeIn vectorTM
1401                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1402                 [AST.ToRange (AST.PrimLit "0")
1403                          (AST.PrimName (AST.NAttribute $
1404                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1405                             (AST.PrimLit "1")) ]))
1406              Nothing
1407     -- for i in 0 to res'range loop
1408     --   res(vec'length-i-1) := vec(i);
1409     -- end loop;
1410     reverseFor =
1411        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1412     -- res(vec'length-i-1) := vec(i);
1413     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1414       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1415                            [AST.PrimName $ AST.NSimple iId]))
1416         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1417                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1418                         AST.PrimName (AST.NSimple iId) AST.:-:
1419                         (AST.PrimLit "1")
1420     -- return res;
1421     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1422
1423
1424 -----------------------------------------------------------------------------
1425 -- A table of builtin functions
1426 -----------------------------------------------------------------------------
1427
1428 -- A function that generates VHDL for a builtin function
1429 type BuiltinBuilder =
1430   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ The destination signal and it's original type
1431   -> CoreSyn.CoreBndr -- ^ The function called
1432   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The value arguments passed (excluding type and
1433                     --   dictionary arguments).
1434   -> TranslatorSession ([AST.ConcSm], [CoreSyn.CoreBndr])
1435   -- ^ The corresponding VHDL concurrent statements and entities
1436   --   instantiated.
1437
1438 -- A map of a builtin function to VHDL function builder
1439 type NameTable = Map.Map String (Int, BuiltinBuilder )
1440
1441 -- | The builtin functions we support. Maps a name to an argument count and a
1442 -- builder function.
1443 globalNameTable :: NameTable
1444 globalNameTable = Map.fromList
1445   [ (exId             , (2, genFCall True          ) )
1446   , (replaceId        , (3, genFCall False          ) )
1447   , (headId           , (1, genFCall True           ) )
1448   , (lastId           , (1, genFCall True           ) )
1449   , (tailId           , (1, genFCall False          ) )
1450   , (initId           , (1, genFCall False          ) )
1451   , (takeId           , (2, genFCall False          ) )
1452   , (dropId           , (2, genFCall False          ) )
1453   , (selId            , (4, genFCall False          ) )
1454   , (plusgtId         , (2, genFCall False          ) )
1455   , (ltplusId         , (2, genFCall False          ) )
1456   , (plusplusId       , (2, genFCall False          ) )
1457   , (mapId            , (2, genMap                  ) )
1458   , (zipWithId        , (3, genZipWith              ) )
1459   , (foldlId          , (3, genFoldl                ) )
1460   , (foldrId          , (3, genFoldr                ) )
1461   , (zipId            , (2, genZip                  ) )
1462   , (unzipId          , (1, genUnzip                ) )
1463   , (shiftlId         , (2, genFCall False          ) )
1464   , (shiftrId         , (2, genFCall False          ) )
1465   , (rotlId           , (1, genFCall False          ) )
1466   , (rotrId           , (1, genFCall False          ) )
1467   , (concatId         , (1, genConcat               ) )
1468   , (reverseId        , (1, genFCall False          ) )
1469   , (iteratenId       , (3, genIteraten             ) )
1470   , (iterateId        , (2, genIterate              ) )
1471   , (generatenId      , (3, genGeneraten            ) )
1472   , (generateId       , (2, genGenerate             ) )
1473   , (emptyId          , (0, genFCall False          ) )
1474   , (singletonId      , (1, genFCall False          ) )
1475   , (copynId          , (2, genFCall False          ) )
1476   , (copyId           , (1, genCopy                 ) )
1477   , (lengthTId        , (1, genFCall False          ) )
1478   , (nullId           , (1, genFCall False          ) )
1479   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1480   , (hwandId          , (2, genOperator2 AST.And    ) )
1481   , (hworId           , (2, genOperator2 AST.Or     ) )
1482   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1483   , (equalityId       , (2, genOperator2 (AST.:=:)  ) )
1484   , (inEqualityId     , (2, genOperator2 (AST.:/=:) ) )
1485   , (ltId             , (2, genOperator2 (AST.:<:)  ) )
1486   , (lteqId           , (2, genOperator2 (AST.:<=:) ) )
1487   , (gtId             , (2, genOperator2 (AST.:>:)  ) )
1488   , (gteqId           , (2, genOperator2 (AST.:>=:) ) )
1489   , (boolOrId         , (2, genOperator2 AST.Or     ) )
1490   , (boolAndId        , (2, genOperator2 AST.And    ) )
1491   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1492   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
1493   , (negateId         , (1, genNegation             ) )
1494   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1495   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1496   , (fromIntegerId    , (1, genFromInteger          ) )
1497   , (resizeWordId     , (1, genResize               ) )
1498   , (resizeIntId      , (1, genResize               ) )
1499   , (sizedIntId       , (1, genSizedInt             ) )
1500   , (smallIntegerId   , (1, genFromInteger          ) )
1501   , (fstId            , (1, genFst                  ) )
1502   , (sndId            , (1, genSnd                  ) )
1503   , (blockRAMId       , (5, genBlockRAM             ) )
1504   , (splitId          , (1, genSplit                ) )
1505   --, (tfvecId          , (1, genTFVec                ) )
1506   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
1507   ]