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