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