cλash/CLasH/VHDL/Generate.hs

   1 module CLasH.VHDL.Generate where
   2
   3 -- Standard modules
   4 import qualified Data.Map as Map
   5 import qualified Maybe
   6 import qualified Data.Either as Either
   7 import Data.Accessor
   8 import Data.Accessor.MonadState as MonadState
   9 import Debug.Trace
  10
  11 -- ForSyDe
  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 IdInfo
  19 import qualified Literal
  20 import qualified Name
  21 import qualified TyCon
  22
  23 -- Local imports
  24 import CLasH.VHDL.Constants
  25 import CLasH.VHDL.VHDLTypes
  26 import CLasH.VHDL.VHDLTools
  27 import CLasH.Utils.Core.CoreTools
  28 import CLasH.Utils.Pretty
  29
  30 -----------------------------------------------------------------------------
  31 -- Functions to generate VHDL for builtin functions
  32 -----------------------------------------------------------------------------
  33
  34 -- | A function to wrap a builder-like function that expects its arguments to
  35 -- be expressions.
  36 genExprArgs wrap dst func args = do
  37   args' <- eitherCoreOrExprArgs args
  38   wrap dst func args'
  39
  40 eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
  41 eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
  42
  43 -- | A function to wrap a builder-like function that expects its arguments to
  44 -- be variables.
  45 genVarArgs ::
  46   (dst -> func -> [Var.Var] -> res)
  47   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
  48 genVarArgs wrap dst func args = wrap dst func args'
  49   where
  50     args' = map exprToVar exprargs
  51     -- Check (rather crudely) that all arguments are CoreExprs
  52     (exprargs, []) = Either.partitionEithers args
  53
  54 -- | A function to wrap a builder-like function that expects its arguments to
  55 -- be Literals
  56 genLitArgs ::
  57   (dst -> func -> [Literal.Literal] -> res)
  58   -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
  59 genLitArgs wrap dst func args = wrap dst func args'
  60   where
  61     args' = map exprToLit litargs
  62     -- FIXME: Check if we were passed an CoreSyn.App
  63     litargs = concat (map getLiterals exprargs)
  64     (exprargs, []) = Either.partitionEithers args
  65
  66 -- | A function to wrap a builder-like function that produces an expression
  67 -- and expects it to be assigned to the destination.
  68 genExprRes ::
  69   ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession AST.Expr)
  70   -> ((Either CoreSyn.CoreBndr AST.VHDLName) -> func -> [arg] -> VHDLSession [AST.ConcSm])
  71 genExprRes wrap dst func args = do
  72   expr <- wrap dst func args
  73   return $ [mkUncondAssign dst expr]
  74
  75 -- | Generate a binary operator application. The first argument should be a
  76 -- constructor from the AST.Expr type, e.g. AST.And.
  77 genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
  78 genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
  79 genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
  80 genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
  81
  82 -- | Generate a unary operator application
  83 genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
  84 genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
  85 genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
  86 genOperator1' op _ f [arg] = return $ op arg
  87
  88 -- | Generate a unary operator application
  89 genNegation :: BuiltinBuilder
  90 genNegation = genVarArgs $ genExprRes genNegation'
  91 genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
  92 genNegation' _ f [arg] = do
  93   arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
  94   let ty = Var.varType arg
  95   let (tycon, args) = Type.splitTyConApp ty
  96   let name = Name.getOccString (TyCon.tyConName tycon)
  97   case name of
  98     "SizedInt" -> return $ AST.Neg arg1
  99     otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
 100
 101 -- | Generate a function call from the destination binder, function name and a
 102 -- list of expressions (its arguments)
 103 genFCall :: Bool -> BuiltinBuilder
 104 genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
 105 genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 106 genFCall' switch (Left res) f args = do
 107   let fname = varToString f
 108   let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
 109   id <- MonadState.lift vsType $ vectorFunId el_ty fname
 110   return $ AST.PrimFCall $ AST.FCall (AST.NSimple id)  $
 111              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 112 genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 113
 114 genFromSizedWord :: BuiltinBuilder
 115 genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
 116 genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 117 genFromSizedWord' (Left res) f args = do
 118   let fname = varToString f
 119   return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId))  $
 120              map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
 121 genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 122
 123 genResize :: BuiltinBuilder
 124 genResize = genExprArgs $ genExprRes genResize'
 125 genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
 126 genResize' (Left res) f [arg] = do {
 127   ; let { ty = Var.varType res
 128         ; (tycon, args) = Type.splitTyConApp ty
 129         ; name = Name.getOccString (TyCon.tyConName tycon)
 130         } ;
 131   ; len <- case name of
 132       "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
 133       "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
 134   ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
 135              [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
 136   }
 137 genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 138
 139 -- FIXME: I'm calling genLitArgs which is very specific function,
 140 -- which needs to be fixed as well
 141 genFromInteger :: BuiltinBuilder
 142 genFromInteger = genLitArgs $ genExprRes genFromInteger'
 143 genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
 144 genFromInteger' (Left res) f lits = do {
 145   ; let { ty = Var.varType res
 146         ; (tycon, args) = Type.splitTyConApp ty
 147         ; name = Name.getOccString (TyCon.tyConName tycon)
 148         } ;
 149   ; case name of
 150     "RangedWord" -> return $ AST.PrimLit (show (last lits))
 151     otherwise -> do {
 152       ; len <- case name of
 153         "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
 154         "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
 155         "RangedWord" -> MonadState.lift vsType $ tfp_to_int (ranged_word_bound_ty ty)
 156       ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
 157       ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
 158                 [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
 159       }
 160   }
 161
 162 genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
 163
 164 genSizedInt :: BuiltinBuilder
 165 genSizedInt = genFromInteger
 166
 167 -- | Generate a Builder for the builtin datacon TFVec
 168 genTFVec :: BuiltinBuilder
 169 genTFVec (Left res) f [Left (CoreSyn.Let (CoreSyn.Rec letBinders) letRes)] = do {
 170   -- Generate Assignments for all the binders
 171   ; letAssigns <- mapM genBinderAssign letBinders
 172   -- Generate assignments for the result (which might be another let binding)
 173   ; (resBinders,resAssignments) <- genResAssign letRes
 174   -- Get all the Assigned binders
 175   ; let assignedBinders = Maybe.catMaybes (map fst letAssigns)
 176   -- Make signal names for all the assigned binders
 177   ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) (assignedBinders ++ resBinders)
 178   -- Assign all the signals to the resulting vector
 179   ; let { vecsigns = mkAggregateSignal sigs
 180         ; vecassign = mkUncondAssign (Left res) vecsigns
 181         } ;
 182   -- Generate all the signal declaration for the assigned binders
 183   ; sig_dec_maybes <- mapM mkSigDec (assignedBinders ++ resBinders)
 184   ; let { sig_decs = map (AST.BDISD) (Maybe.catMaybes $ sig_dec_maybes)
 185   -- Setup the VHDL Block
 186         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
 187         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) sig_decs ((concat (map snd letAssigns)) ++ resAssignments ++ [vecassign])
 188         } ;
 189   -- Return the block statement coressponding to the TFVec literal
 190   ; return $ [AST.CSBSm block]
 191   }
 192   where
 193     genBinderAssign :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> VHDLSession (Maybe CoreSyn.CoreBndr, [AST.ConcSm])
 194     -- For now we only translate applications
 195     genBinderAssign (bndr, app@(CoreSyn.App _ _)) = do
 196       let (CoreSyn.Var f, args) = CoreSyn.collectArgs app
 197       let valargs = get_val_args (Var.varType f) args
 198       apps <- genApplication (Left bndr) f (map Left valargs)
 199       return (Just bndr, apps)
 200     genBinderAssign _ = return (Nothing,[])
 201     genResAssign :: CoreSyn.CoreExpr -> VHDLSession ([CoreSyn.CoreBndr], [AST.ConcSm])
 202     genResAssign app@(CoreSyn.App _ letexpr) = do
 203       case letexpr of
 204         (CoreSyn.Let (CoreSyn.Rec letbndrs) letres) -> do
 205           letapps <- mapM genBinderAssign letbndrs
 206           let bndrs = Maybe.catMaybes (map fst letapps)
 207           let app = (map snd letapps)
 208           (vars, apps) <- genResAssign letres
 209           return ((bndrs ++ vars),((concat app) ++ apps))
 210         otherwise -> return ([],[])
 211     genResAssign _ = return ([],[])
 212
 213 genTFVec (Left res) f [Left app@(CoreSyn.App _ _)] = do {
 214   ; let { elems = reduceCoreListToHsList app
 215   -- Make signal names for all the binders
 216         ; binders = map (\expr -> case expr of
 217                           (CoreSyn.Var b) -> b
 218                           otherwise -> error $ "\nGenerate.genTFVec: Cannot generate TFVec: "
 219                             ++ show res ++ ", with elems:\n" ++ show elems ++ "\n" ++ pprString elems) elems
 220         } ;
 221   ; sigs <- mapM (\x -> MonadState.lift vsType $ varToVHDLExpr x) binders
 222   -- Assign all the signals to the resulting vector
 223   ; let { vecsigns = mkAggregateSignal sigs
 224         ; vecassign = mkUncondAssign (Left res) vecsigns
 225   -- Setup the VHDL Block
 226         ; block_label = mkVHDLExtId ("TFVec_" ++ show (varToString res))
 227         ; block = AST.BlockSm block_label [] (AST.PMapAspect []) [] [vecassign]
 228         } ;
 229   -- Return the block statement coressponding to the TFVec literal
 230   ; return $ [AST.CSBSm block]
 231   }
 232
 233 genTFVec (Left name) _ [Left xs] = error $ "\nGenerate.genTFVec: Cannot generate TFVec: " ++ show name ++ ", with elems:\n" ++ show xs ++ "\n" ++ pprString xs
 234
 235 genTFVec (Right name) _ _ = error $ "\nGenerate.genTFVec: Cannot generate TFVec assigned to VHDLName: " ++ show name
 236
 237 -- | Generate a generate statement for the builtin function "map"
 238 genMap :: BuiltinBuilder
 239 genMap (Left res) f [Left mapped_f, Left (CoreSyn.Var arg)] = do {
 240   -- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
 241   -- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
 242   -- we must index it (which we couldn't if it was a VHDL Expr, since only
 243   -- VHDLNames can be indexed).
 244   -- Setup the generate scheme
 245   ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 246           -- TODO: Use something better than varToString
 247   ; let { label       = mkVHDLExtId ("mapVector" ++ (varToString res))
 248         ; n_id        = mkVHDLBasicId "n"
 249         ; n_expr      = idToVHDLExpr n_id
 250         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 251         ; genScheme   = AST.ForGn n_id range
 252           -- Create the content of the generate statement: Applying the mapped_f to
 253           -- each of the elements in arg, storing to each element in res
 254         ; resname     = mkIndexedName (varToVHDLName res) n_expr
 255         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
 256         ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
 257         ; valargs = get_val_args (Var.varType real_f) already_mapped_args
 258         } ;
 259   ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
 260     -- Return the generate statement
 261   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
 262   }
 263
 264 genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
 265
 266 genZipWith :: BuiltinBuilder
 267 genZipWith = genVarArgs genZipWith'
 268 genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 269 genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
 270   -- Setup the generate scheme
 271   ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 272           -- TODO: Use something better than varToString
 273   ; let { label       = mkVHDLExtId ("zipWithVector" ++ (varToString res))
 274         ; n_id        = mkVHDLBasicId "n"
 275         ; n_expr      = idToVHDLExpr n_id
 276         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 277         ; genScheme   = AST.ForGn n_id range
 278           -- Create the content of the generate statement: Applying the zipped_f to
 279           -- each of the elements in arg1 and arg2, storing to each element in res
 280         ; resname     = mkIndexedName (varToVHDLName res) n_expr
 281         ; argexpr1    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
 282         ; argexpr2    = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
 283         } ;
 284   ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
 285     -- Return the generate functions
 286   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
 287   }
 288
 289 genFoldl :: BuiltinBuilder
 290 genFoldl = genFold True
 291
 292 genFoldr :: BuiltinBuilder
 293 genFoldr = genFold False
 294
 295 genFold :: Bool -> BuiltinBuilder
 296 genFold left = genVarArgs (genFold' left)
 297
 298 genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 299 genFold' left res f args@[folded_f , start ,vec]= do
 300   len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
 301   genFold'' len left res f args
 302
 303 genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 304 -- Special case for an empty input vector, just assign start to res
 305 genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
 306   arg <- MonadState.lift vsType $ varToVHDLExpr start
 307   return [mkUncondAssign (Left res) arg]
 308
 309 genFold'' len left (Left res) f [folded_f, start, vec] = do
 310   -- The vector length
 311   --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 312   -- An expression for len-1
 313   let len_min_expr = (AST.PrimLit $ show (len-1))
 314   -- evec is (TFVec n), so it still needs an element type
 315   let (nvec, _) = Type.splitAppTy (Var.varType vec)
 316   -- Put the type of the start value in nvec, this will be the type of our
 317   -- temporary vector
 318   let tmp_ty = Type.mkAppTy nvec (Var.varType start)
 319   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
 320   tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
 321   -- Setup the generate scheme
 322   let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
 323   let block_label = mkVHDLExtId ("foldlVector" ++ (varToString res))
 324   let gen_range = if left then AST.ToRange (AST.PrimLit "0") len_min_expr
 325                   else AST.DownRange len_min_expr (AST.PrimLit "0")
 326   let gen_scheme   = AST.ForGn n_id gen_range
 327   -- Make the intermediate vector
 328   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
 329   -- Create the generate statement
 330   cells <- sequence [genFirstCell, genOtherCell]
 331   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
 332   -- Assign tmp[len-1] or tmp[0] to res
 333   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr (if left then
 334                     (mkIndexedName tmp_name (AST.PrimLit $ show (len-1))) else
 335                     (mkIndexedName tmp_name (AST.PrimLit "0")))
 336   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
 337   return [AST.CSBSm block]
 338   where
 339     -- An id for the counter
 340     n_id = mkVHDLBasicId "n"
 341     n_cur = idToVHDLExpr n_id
 342     -- An expression for previous n
 343     n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
 344                      else (n_cur AST.:+: (AST.PrimLit "1"))
 345     -- An id for the tmp result vector
 346     tmp_id = mkVHDLBasicId "tmp"
 347     tmp_name = AST.NSimple tmp_id
 348     -- Generate parts of the fold
 349     genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
 350     genFirstCell = do
 351       len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 352       let cond_label = mkVHDLExtId "firstcell"
 353       -- if n == 0 or n == len-1
 354       let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
 355                                                   else (AST.PrimLit $ show (len-1)))
 356       -- Output to tmp[current n]
 357       let resname = mkIndexedName tmp_name n_cur
 358       -- Input from start
 359       argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
 360       -- Input from vec[current n]
 361       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
 362       app_concsms <- genApplication (Right resname) folded_f  ( if left then
 363                                                                   [Right argexpr1, Right argexpr2]
 364                                                                 else
 365                                                                   [Right argexpr2, Right argexpr1]
 366                                                               )
 367       -- Return the conditional generate part
 368       return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
 369
 370     genOtherCell = do
 371       len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
 372       let cond_label = mkVHDLExtId "othercell"
 373       -- if n > 0 or n < len-1
 374       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
 375                                                    else (AST.PrimLit $ show (len-1)))
 376       -- Output to tmp[current n]
 377       let resname = mkIndexedName tmp_name n_cur
 378       -- Input from tmp[previous n]
 379       let argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
 380       -- Input from vec[current n]
 381       let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
 382       app_concsms <- genApplication (Right resname) folded_f  ( if left then
 383                                                                   [Right argexpr1, Right argexpr2]
 384                                                                 else
 385                                                                   [Right argexpr2, Right argexpr1]
 386                                                               )
 387       -- Return the conditional generate part
 388       return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
 389
 390 -- | Generate a generate statement for the builtin function "zip"
 391 genZip :: BuiltinBuilder
 392 genZip = genVarArgs genZip'
 393 genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 394 genZip' (Left res) f args@[arg1, arg2] = do {
 395     -- Setup the generate scheme
 396   ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
 397           -- TODO: Use something better than varToString
 398   ; let { label           = mkVHDLExtId ("zipVector" ++ (varToString res))
 399         ; n_id            = mkVHDLBasicId "n"
 400         ; n_expr          = idToVHDLExpr n_id
 401         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 402         ; genScheme       = AST.ForGn n_id range
 403         ; resname'        = mkIndexedName (varToVHDLName res) n_expr
 404         ; argexpr1        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
 405         ; argexpr2        = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
 406         } ;
 407   ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
 408   ; let { resnameA    = mkSelectedName resname' (labels!!0)
 409         ; resnameB    = mkSelectedName resname' (labels!!1)
 410         ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
 411         ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
 412         } ;
 413     -- Return the generate functions
 414   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
 415   }
 416
 417 -- | Generate a generate statement for the builtin function "unzip"
 418 genUnzip :: BuiltinBuilder
 419 genUnzip = genVarArgs genUnzip'
 420 genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 421 genUnzip' (Left res) f args@[arg] = do {
 422     -- Setup the generate scheme
 423   ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 424     -- TODO: Use something better than varToString
 425   ; let { label           = mkVHDLExtId ("unzipVector" ++ (varToString res))
 426         ; n_id            = mkVHDLBasicId "n"
 427         ; n_expr          = idToVHDLExpr n_id
 428         ; range           = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
 429         ; genScheme       = AST.ForGn n_id range
 430         ; resname'        = varToVHDLName res
 431         ; argexpr'        = mkIndexedName (varToVHDLName arg) n_expr
 432         } ;
 433   ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
 434   ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
 435   ; let { resnameA    = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
 436         ; resnameB    = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
 437         ; argexprA    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
 438         ; argexprB    = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
 439         ; resA_assign = mkUncondAssign (Right resnameA) argexprA
 440         ; resB_assign = mkUncondAssign (Right resnameB) argexprB
 441         } ;
 442     -- Return the generate functions
 443   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
 444   }
 445
 446 genCopy :: BuiltinBuilder
 447 genCopy = genVarArgs genCopy'
 448 genCopy' :: (Either CoreSyn.CoreBndr AST.VHDLName ) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 449 genCopy' (Left res) f args@[arg] =
 450   let
 451     resExpr = AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 452                 (AST.PrimName $ (varToVHDLName arg))]
 453     out_assign = mkUncondAssign (Left res) resExpr
 454   in
 455     return [out_assign]
 456
 457 genConcat :: BuiltinBuilder
 458 genConcat = genVarArgs genConcat'
 459 genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 460 genConcat' (Left res) f args@[arg] = do {
 461     -- Setup the generate scheme
 462   ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
 463   ; let (_, nvec) = Type.splitAppTy (Var.varType arg)
 464   ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
 465           -- TODO: Use something better than varToString
 466   ; let { label       = mkVHDLExtId ("concatVector" ++ (varToString res))
 467         ; n_id        = mkVHDLBasicId "n"
 468         ; n_expr      = idToVHDLExpr n_id
 469         ; fromRange   = n_expr AST.:*: (AST.PrimLit $ show len2)
 470         ; genScheme   = AST.ForGn n_id range
 471           -- Create the content of the generate statement: Applying the mapped_f to
 472           -- each of the elements in arg, storing to each element in res
 473         ; toRange     = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
 474         ; range       = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
 475         ; resname     = vecSlice fromRange toRange
 476         ; argexpr     = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
 477         ; out_assign  = mkUncondAssign (Right resname) argexpr
 478         } ;
 479     -- Return the generate statement
 480   ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
 481   }
 482   where
 483     vecSlice init last =  AST.NSlice (AST.SliceName (varToVHDLName res)
 484                             (AST.ToRange init last))
 485
 486 genIteraten :: BuiltinBuilder
 487 genIteraten dst f args = genIterate dst f (tail args)
 488
 489 genIterate :: BuiltinBuilder
 490 genIterate = genIterateOrGenerate True
 491
 492 genGeneraten :: BuiltinBuilder
 493 genGeneraten dst f args = genGenerate dst f (tail args)
 494
 495 genGenerate :: BuiltinBuilder
 496 genGenerate = genIterateOrGenerate False
 497
 498 genIterateOrGenerate :: Bool -> BuiltinBuilder
 499 genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
 500
 501 genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 502 genIterateOrGenerate' iter (Left res) f args = do
 503   len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
 504   genIterateOrGenerate'' len iter (Left res) f args
 505
 506 genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
 507 -- Special case for an empty input vector, just assign start to res
 508 genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
 509
 510 genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
 511   -- The vector length
 512   -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
 513   -- An expression for len-1
 514   let len_min_expr = (AST.PrimLit $ show (len-1))
 515   -- -- evec is (TFVec n), so it still needs an element type
 516   -- let (nvec, _) = splitAppTy (Var.varType vec)
 517   -- -- Put the type of the start value in nvec, this will be the type of our
 518   -- -- temporary vector
 519   let tmp_ty = Var.varType res
 520   let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
 521   tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
 522   -- Setup the generate scheme
 523   let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
 524   let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
 525   let gen_range = AST.ToRange (AST.PrimLit "0") len_min_expr
 526   let gen_scheme   = AST.ForGn n_id gen_range
 527   -- Make the intermediate vector
 528   let  tmp_dec     = AST.BDISD $ AST.SigDec tmp_id tmp_vhdl_ty Nothing
 529   -- Create the generate statement
 530   cells <- sequence [genFirstCell, genOtherCell]
 531   let gen_sm = AST.GenerateSm gen_label gen_scheme [] (map AST.CSGSm cells)
 532   -- Assign tmp[len-1] or tmp[0] to res
 533   let out_assign = mkUncondAssign (Left res) $ vhdlNameToVHDLExpr tmp_name
 534   let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
 535   return [AST.CSBSm block]
 536   where
 537     -- An id for the counter
 538     n_id = mkVHDLBasicId "n"
 539     n_cur = idToVHDLExpr n_id
 540     -- An expression for previous n
 541     n_prev = n_cur AST.:-: (AST.PrimLit "1")
 542     -- An id for the tmp result vector
 543     tmp_id = mkVHDLBasicId "tmp"
 544     tmp_name = AST.NSimple tmp_id
 545     -- Generate parts of the fold
 546     genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
 547     genFirstCell = do
 548       let cond_label = mkVHDLExtId "firstcell"
 549       -- if n == 0 or n == len-1
 550       let cond_scheme = AST.IfGn $ n_cur AST.:=: (AST.PrimLit "0")
 551       -- Output to tmp[current n]
 552       let resname = mkIndexedName tmp_name n_cur
 553       -- Input from start
 554       argexpr <- MonadState.lift vsType $ varToVHDLExpr start
 555       let startassign = mkUncondAssign (Right resname) argexpr
 556       app_concsms <- genApplication (Right resname) app_f  [Right argexpr]
 557       -- Return the conditional generate part
 558       return $ AST.GenerateSm cond_label cond_scheme [] (if iter then
 559                                                           [startassign]
 560                                                          else
 561                                                           app_concsms
 562                                                         )
 563
 564     genOtherCell = do
 565       let cond_label = mkVHDLExtId "othercell"
 566       -- if n > 0 or n < len-1
 567       let cond_scheme = AST.IfGn $ n_cur AST.:/=: (AST.PrimLit "0")
 568       -- Output to tmp[current n]
 569       let resname = mkIndexedName tmp_name n_cur
 570       -- Input from tmp[previous n]
 571       let argexpr = vhdlNameToVHDLExpr $ mkIndexedName tmp_name n_prev
 572       app_concsms <- genApplication (Right resname) app_f [Right argexpr]
 573       -- Return the conditional generate part
 574       return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
 575
 576
 577 -----------------------------------------------------------------------------
 578 -- Function to generate VHDL for applications
 579 -----------------------------------------------------------------------------
 580 genApplication ::
 581   (Either CoreSyn.CoreBndr AST.VHDLName) -- ^ Where to store the result?
 582   -> CoreSyn.CoreBndr -- ^ The function to apply
 583   -> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
 584   -> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
 585 genApplication dst f args = do
 586   case Var.isGlobalId f of
 587     False -> do
 588       signatures <- getA vsSignatures
 589       -- This is a local id, so it should be a function whose definition we
 590       -- have and which can be turned into a component instantiation.
 591       case (Map.lookup f signatures) of
 592         Just signature -> do
 593           args' <- eitherCoreOrExprArgs args
 594           -- We have a signature, this is a top level binding. Generate a
 595           -- component instantiation.
 596           let entity_id = ent_id signature
 597           -- TODO: Using show here isn't really pretty, but we'll need some
 598           -- unique-ish value...
 599           let label = "comp_ins_" ++ (either show prettyShow) dst
 600           let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
 601           return [mkComponentInst label entity_id portmaps]
 602         Nothing -> do
 603           -- No signature, so this must be a local variable reference. It
 604           -- should have a representable type (and thus, no arguments) and a
 605           -- signal should be generated for it. Just generate an
 606           -- unconditional assignment here.
 607           f' <- MonadState.lift vsType $ varToVHDLExpr f
 608           return $ [mkUncondAssign dst f']
 609     True ->
 610       case Var.idDetails f of
 611         IdInfo.DataConWorkId dc -> case dst of
 612           -- It's a datacon. Create a record from its arguments.
 613           Left bndr -> do
 614             -- We have the bndr, so we can get at the type
 615             labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
 616             args' <- eitherCoreOrExprArgs args
 617             return $ zipWith mkassign labels $ args'
 618             where
 619               mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
 620               mkassign label arg =
 621                 let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
 622                 mkUncondAssign (Right sel_name) arg
 623           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
 624         IdInfo.DataConWrapId dc -> case dst of
 625           -- It's a datacon. Create a record from its arguments.
 626           Left bndr -> do
 627             case (Map.lookup (varToString f) globalNameTable) of
 628              Just (arg_count, builder) ->
 629               if length args == arg_count then
 630                 builder dst f args
 631               else
 632                 error $ "\nGenerate.genApplication(DataConWrapId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 633              Nothing -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper: " ++ (show dc)
 634           Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconwrapper application without an original binder"
 635         IdInfo.VanillaId -> do
 636           -- It's a global value imported from elsewhere. These can be builtin
 637           -- functions. Look up the function name in the name table and execute
 638           -- the associated builder if there is any and the argument count matches
 639           -- (this should always be the case if it typechecks, but just to be
 640           -- sure...).
 641           case (Map.lookup (varToString f) globalNameTable) of
 642             Just (arg_count, builder) ->
 643               if length args == arg_count then
 644                 builder dst f args
 645               else
 646                 error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 647             Nothing -> error $ ("\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ (pprString f))
 648         IdInfo.ClassOpId cls -> do
 649           -- FIXME: Not looking for what instance this class op is called for
 650           -- Is quite stupid of course.
 651           case (Map.lookup (varToString f) globalNameTable) of
 652             Just (arg_count, builder) ->
 653               if length args == arg_count then
 654                 builder dst f args
 655               else
 656                 error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
 657             Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
 658         details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
 659
 660 -----------------------------------------------------------------------------
 661 -- Functions to generate functions dealing with vectors.
 662 -----------------------------------------------------------------------------
 663
 664 -- Returns the VHDLId of the vector function with the given name for the given
 665 -- element type. Generates -- this function if needed.
 666 vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
 667 vectorFunId el_ty fname = do
 668   let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
 669   elemTM <- vhdl_ty error_msg el_ty
 670   -- TODO: This should not be duplicated from mk_vector_ty. Probably but it in
 671   -- the VHDLState or something.
 672   let vectorTM = mkVHDLExtId $ "vector_" ++ (AST.fromVHDLId elemTM)
 673   typefuns <- getA vsTypeFuns
 674   case Map.lookup (OrdType el_ty, fname) typefuns of
 675     -- Function already generated, just return it
 676     Just (id, _) -> return id
 677     -- Function not generated yet, generate it
 678     Nothing -> do
 679       let functions = genUnconsVectorFuns elemTM vectorTM
 680       case lookup fname functions of
 681         Just body -> do
 682           modA vsTypeFuns $ Map.insert (OrdType el_ty, fname) (function_id, (fst body))
 683           mapM_ (vectorFunId el_ty) (snd body)
 684           return function_id
 685         Nothing -> error $ "\nGenerate.vectorFunId: I don't know how to generate vector function " ++ fname
 686   where
 687     function_id = mkVHDLExtId fname
 688
 689 genUnconsVectorFuns :: AST.TypeMark -- ^ type of the vector elements
 690                     -> AST.TypeMark -- ^ type of the vector
 691                     -> [(String, (AST.SubProgBody, [String]))]
 692 genUnconsVectorFuns elemTM vectorTM  =
 693   [ (exId, (AST.SubProgBody exSpec      []                  [exExpr],[]))
 694   , (replaceId, (AST.SubProgBody replaceSpec [AST.SPVD replaceVar] [replaceExpr,replaceRet],[]))
 695   , (lastId, (AST.SubProgBody lastSpec    []                  [lastExpr],[]))
 696   , (initId, (AST.SubProgBody initSpec    [AST.SPVD initVar]  [initExpr, initRet],[]))
 697   , (minimumId, (AST.SubProgBody minimumSpec [] [minimumExpr],[]))
 698   , (takeId, (AST.SubProgBody takeSpec    [AST.SPVD takeVar]  [takeExpr, takeRet],[minimumId]))
 699   , (dropId, (AST.SubProgBody dropSpec    [AST.SPVD dropVar]  [dropExpr, dropRet],[]))
 700   , (plusgtId, (AST.SubProgBody plusgtSpec  [AST.SPVD plusgtVar] [plusgtExpr, plusgtRet],[]))
 701   , (emptyId, (AST.SubProgBody emptySpec   [AST.SPCD emptyVar] [emptyExpr],[]))
 702   , (singletonId, (AST.SubProgBody singletonSpec [AST.SPVD singletonVar] [singletonRet],[]))
 703   , (copynId, (AST.SubProgBody copynSpec    [AST.SPVD copynVar]      [copynExpr],[]))
 704   , (selId, (AST.SubProgBody selSpec  [AST.SPVD selVar] [selFor, selRet],[]))
 705   , (ltplusId, (AST.SubProgBody ltplusSpec [AST.SPVD ltplusVar] [ltplusExpr, ltplusRet],[]))
 706   , (plusplusId, (AST.SubProgBody plusplusSpec [AST.SPVD plusplusVar] [plusplusExpr, plusplusRet],[]))
 707   , (lengthTId, (AST.SubProgBody lengthTSpec [] [lengthTExpr],[]))
 708   , (shiftlId, (AST.SubProgBody shiftlSpec [AST.SPVD shiftlVar] [shiftlExpr, shiftlRet], [initId]))
 709   , (shiftrId, (AST.SubProgBody shiftrSpec [AST.SPVD shiftrVar] [shiftrExpr, shiftrRet], [tailId]))
 710   , (nullId, (AST.SubProgBody nullSpec [] [nullExpr], []))
 711   , (rotlId, (AST.SubProgBody rotlSpec [AST.SPVD rotlVar] [rotlExpr, rotlRet], [nullId, lastId, initId]))
 712   , (rotrId, (AST.SubProgBody rotrSpec [AST.SPVD rotrVar] [rotrExpr, rotrRet], [nullId, tailId, headId]))
 713   , (reverseId, (AST.SubProgBody reverseSpec [AST.SPVD reverseVar] [reverseFor, reverseRet], []))
 714   ]
 715   where
 716     ixPar   = AST.unsafeVHDLBasicId "ix"
 717     vecPar  = AST.unsafeVHDLBasicId "vec"
 718     vec1Par = AST.unsafeVHDLBasicId "vec1"
 719     vec2Par = AST.unsafeVHDLBasicId "vec2"
 720     nPar    = AST.unsafeVHDLBasicId "n"
 721     leftPar = AST.unsafeVHDLBasicId "nLeft"
 722     rightPar = AST.unsafeVHDLBasicId "nRight"
 723     iId     = AST.unsafeVHDLBasicId "i"
 724     iPar    = iId
 725     aPar    = AST.unsafeVHDLBasicId "a"
 726     fPar = AST.unsafeVHDLBasicId "f"
 727     sPar = AST.unsafeVHDLBasicId "s"
 728     resId   = AST.unsafeVHDLBasicId "res"
 729     exSpec = AST.Function (mkVHDLExtId exId) [AST.IfaceVarDec vecPar vectorTM,
 730                                AST.IfaceVarDec ixPar  naturalTM] elemTM
 731     exExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NIndexed
 732               (AST.IndexedName (AST.NSimple vecPar) [AST.PrimName $
 733                 AST.NSimple ixPar]))
 734     replaceSpec = AST.Function (mkVHDLExtId replaceId)  [ AST.IfaceVarDec vecPar vectorTM
 735                                           , AST.IfaceVarDec iPar   naturalTM
 736                                           , AST.IfaceVarDec aPar   elemTM
 737                                           ] vectorTM
 738        -- variable res : fsvec_x (0 to vec'length-1);
 739     replaceVar =
 740          AST.VarDec resId
 741                 (AST.SubtypeIn vectorTM
 742                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 743                    [AST.ToRange (AST.PrimLit "0")
 744                             (AST.PrimName (AST.NAttribute $
 745                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 746                                 (AST.PrimLit "1"))   ]))
 747                 Nothing
 748        --  res AST.:= vec(0 to i-1) & a & vec(i+1 to length'vec-1)
 749     replaceExpr = AST.NSimple resId AST.:=
 750            (vecSlice (AST.PrimLit "0") (AST.PrimName (AST.NSimple iPar) AST.:-: AST.PrimLit "1") AST.:&:
 751             AST.PrimName (AST.NSimple aPar) AST.:&:
 752              vecSlice (AST.PrimName (AST.NSimple iPar) AST.:+: AST.PrimLit "1")
 753                       ((AST.PrimName (AST.NAttribute $
 754                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 755                                                               AST.:-: AST.PrimLit "1"))
 756     replaceRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 757     vecSlice init last =  AST.PrimName (AST.NSlice
 758                                         (AST.SliceName
 759                                               (AST.NSimple vecPar)
 760                                               (AST.ToRange init last)))
 761     lastSpec = AST.Function (mkVHDLExtId lastId) [AST.IfaceVarDec vecPar vectorTM] elemTM
 762        -- return vec(vec'length-1);
 763     lastExpr = AST.ReturnSm (Just $ (AST.PrimName $ AST.NIndexed (AST.IndexedName
 764                     (AST.NSimple vecPar)
 765                     [AST.PrimName (AST.NAttribute $
 766                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 767                                                              AST.:-: AST.PrimLit "1"])))
 768     initSpec = AST.Function (mkVHDLExtId initId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 769        -- variable res : fsvec_x (0 to vec'length-2);
 770     initVar =
 771          AST.VarDec resId
 772                 (AST.SubtypeIn vectorTM
 773                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 774                    [AST.ToRange (AST.PrimLit "0")
 775                             (AST.PrimName (AST.NAttribute $
 776                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 777                                 (AST.PrimLit "2"))   ]))
 778                 Nothing
 779        -- resAST.:= vec(0 to vec'length-2)
 780     initExpr = AST.NSimple resId AST.:= (vecSlice
 781                                (AST.PrimLit "0")
 782                                (AST.PrimName (AST.NAttribute $
 783                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 784                                                              AST.:-: AST.PrimLit "2"))
 785     initRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 786     minimumSpec = AST.Function (mkVHDLExtId minimumId) [AST.IfaceVarDec leftPar   naturalTM,
 787                                    AST.IfaceVarDec rightPar naturalTM ] naturalTM
 788     minimumExpr = AST.IfSm ((AST.PrimName $ AST.NSimple leftPar) AST.:<: (AST.PrimName $ AST.NSimple rightPar))
 789                         [AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple leftPar)]
 790                         []
 791                         (Just $ AST.Else [minimumExprRet])
 792       where minimumExprRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple rightPar)
 793     takeSpec = AST.Function (mkVHDLExtId takeId) [AST.IfaceVarDec nPar   naturalTM,
 794                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 795        -- variable res : fsvec_x (0 to (minimum (n,vec'length))-1);
 796     minLength = AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId minimumId))
 797                               [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple nPar)
 798                               ,Nothing AST.:=>: AST.ADExpr (AST.PrimName (AST.NAttribute $
 799                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]
 800     takeVar =
 801          AST.VarDec resId
 802                 (AST.SubtypeIn vectorTM
 803                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 804                    [AST.ToRange (AST.PrimLit "0")
 805                                (minLength AST.:-:
 806                                 (AST.PrimLit "1"))   ]))
 807                 Nothing
 808        -- res AST.:= vec(0 to n-1)
 809     takeExpr = AST.NSimple resId AST.:=
 810                     (vecSlice (AST.PrimLit "0")
 811                               (minLength AST.:-: AST.PrimLit "1"))
 812     takeRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 813     dropSpec = AST.Function (mkVHDLExtId dropId) [AST.IfaceVarDec nPar   naturalTM,
 814                                    AST.IfaceVarDec vecPar vectorTM ] vectorTM
 815        -- variable res : fsvec_x (0 to vec'length-n-1);
 816     dropVar =
 817          AST.VarDec resId
 818                 (AST.SubtypeIn vectorTM
 819                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 820                    [AST.ToRange (AST.PrimLit "0")
 821                             (AST.PrimName (AST.NAttribute $
 822                               AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 823                                (AST.PrimName $ AST.NSimple nPar)AST.:-: (AST.PrimLit "1")) ]))
 824                Nothing
 825        -- res AST.:= vec(n to vec'length-1)
 826     dropExpr = AST.NSimple resId AST.:= (vecSlice
 827                                (AST.PrimName $ AST.NSimple nPar)
 828                                (AST.PrimName (AST.NAttribute $
 829                                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing)
 830                                                              AST.:-: AST.PrimLit "1"))
 831     dropRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 832     plusgtSpec = AST.Function (mkVHDLExtId plusgtId) [AST.IfaceVarDec aPar   elemTM,
 833                                        AST.IfaceVarDec vecPar vectorTM] vectorTM
 834     -- variable res : fsvec_x (0 to vec'length);
 835     plusgtVar =
 836       AST.VarDec resId
 837              (AST.SubtypeIn vectorTM
 838                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 839                 [AST.ToRange (AST.PrimLit "0")
 840                         (AST.PrimName (AST.NAttribute $
 841                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
 842              Nothing
 843     plusgtExpr = AST.NSimple resId AST.:=
 844                    ((AST.PrimName $ AST.NSimple aPar) AST.:&:
 845                     (AST.PrimName $ AST.NSimple vecPar))
 846     plusgtRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 847     emptySpec = AST.Function (mkVHDLExtId emptyId) [] vectorTM
 848     emptyVar =
 849           AST.ConstDec resId
 850               (AST.SubtypeIn vectorTM Nothing)
 851               (Just $ AST.PrimLit "\"\"")
 852     emptyExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
 853     singletonSpec = AST.Function (mkVHDLExtId singletonId) [AST.IfaceVarDec aPar elemTM ]
 854                                          vectorTM
 855     -- variable res : fsvec_x (0 to 0) := (others => a);
 856     singletonVar =
 857       AST.VarDec resId
 858              (AST.SubtypeIn vectorTM
 859                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 860                 [AST.ToRange (AST.PrimLit "0") (AST.PrimLit "0")]))
 861              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 862                                           (AST.PrimName $ AST.NSimple aPar)])
 863     singletonRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 864     copynSpec = AST.Function (mkVHDLExtId copynId) [AST.IfaceVarDec nPar   naturalTM,
 865                                    AST.IfaceVarDec aPar   elemTM   ] vectorTM
 866     -- variable res : fsvec_x (0 to n-1) := (others => a);
 867     copynVar =
 868       AST.VarDec resId
 869              (AST.SubtypeIn vectorTM
 870                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 871                 [AST.ToRange (AST.PrimLit "0")
 872                             ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 873                              (AST.PrimLit "1"))   ]))
 874              (Just $ AST.Aggregate [AST.ElemAssoc (Just AST.Others)
 875                                           (AST.PrimName $ AST.NSimple aPar)])
 876     -- return res
 877     copynExpr = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 878     selSpec = AST.Function (mkVHDLExtId selId) [AST.IfaceVarDec fPar   naturalTM,
 879                                AST.IfaceVarDec sPar   naturalTM,
 880                                AST.IfaceVarDec nPar   naturalTM,
 881                                AST.IfaceVarDec vecPar vectorTM ] vectorTM
 882     -- variable res : fsvec_x (0 to n-1);
 883     selVar =
 884       AST.VarDec resId
 885                 (AST.SubtypeIn vectorTM
 886                   (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 887                     [AST.ToRange (AST.PrimLit "0")
 888                       ((AST.PrimName (AST.NSimple nPar)) AST.:-:
 889                       (AST.PrimLit "1"))   ])
 890                 )
 891                 Nothing
 892     -- for i res'range loop
 893     --   res(i) := vec(f+i*s);
 894     -- end loop;
 895     selFor = AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [selAssign]
 896     -- res(i) := vec(f+i*s);
 897     selAssign = let origExp = AST.PrimName (AST.NSimple fPar) AST.:+:
 898                                 (AST.PrimName (AST.NSimple iId) AST.:*:
 899                                   AST.PrimName (AST.NSimple sPar)) in
 900                                   AST.NIndexed (AST.IndexedName (AST.NSimple resId) [AST.PrimName (AST.NSimple iId)]) AST.:=
 901                                     (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar) [origExp]))
 902     -- return res;
 903     selRet =  AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
 904     ltplusSpec = AST.Function (mkVHDLExtId ltplusId) [AST.IfaceVarDec vecPar vectorTM,
 905                                         AST.IfaceVarDec aPar   elemTM] vectorTM
 906      -- variable res : fsvec_x (0 to vec'length);
 907     ltplusVar =
 908       AST.VarDec resId
 909         (AST.SubtypeIn vectorTM
 910           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 911             [AST.ToRange (AST.PrimLit "0")
 912               (AST.PrimName (AST.NAttribute $
 913                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))]))
 914         Nothing
 915     ltplusExpr = AST.NSimple resId AST.:=
 916                      ((AST.PrimName $ AST.NSimple vecPar) AST.:&:
 917                       (AST.PrimName $ AST.NSimple aPar))
 918     ltplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 919     plusplusSpec = AST.Function (mkVHDLExtId plusplusId) [AST.IfaceVarDec vec1Par vectorTM,
 920                                              AST.IfaceVarDec vec2Par vectorTM]
 921                                              vectorTM
 922     -- variable res : fsvec_x (0 to vec1'length + vec2'length -1);
 923     plusplusVar =
 924       AST.VarDec resId
 925         (AST.SubtypeIn vectorTM
 926           (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 927             [AST.ToRange (AST.PrimLit "0")
 928               (AST.PrimName (AST.NAttribute $
 929                 AST.AttribName (AST.NSimple vec1Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:+:
 930                   AST.PrimName (AST.NAttribute $
 931                 AST.AttribName (AST.NSimple vec2Par) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 932                   AST.PrimLit "1")]))
 933        Nothing
 934     plusplusExpr = AST.NSimple resId AST.:=
 935                      ((AST.PrimName $ AST.NSimple vec1Par) AST.:&:
 936                       (AST.PrimName $ AST.NSimple vec2Par))
 937     plusplusRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 938     lengthTSpec = AST.Function (mkVHDLExtId lengthTId) [AST.IfaceVarDec vecPar vectorTM] naturalTM
 939     lengthTExpr = AST.ReturnSm (Just $ AST.PrimName (AST.NAttribute $
 940                                 AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing))
 941     shiftlSpec = AST.Function (mkVHDLExtId shiftlId) [AST.IfaceVarDec vecPar vectorTM,
 942                                    AST.IfaceVarDec aPar   elemTM  ] vectorTM
 943     -- variable res : fsvec_x (0 to vec'length-1);
 944     shiftlVar =
 945      AST.VarDec resId
 946             (AST.SubtypeIn vectorTM
 947               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 948                [AST.ToRange (AST.PrimLit "0")
 949                         (AST.PrimName (AST.NAttribute $
 950                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 951                            (AST.PrimLit "1")) ]))
 952             Nothing
 953     -- res := a & init(vec)
 954     shiftlExpr = AST.NSimple resId AST.:=
 955                     (AST.PrimName (AST.NSimple aPar) AST.:&:
 956                      (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
 957                        [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
 958     shiftlRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 959     shiftrSpec = AST.Function (mkVHDLExtId shiftrId) [AST.IfaceVarDec vecPar vectorTM,
 960                                        AST.IfaceVarDec aPar   elemTM  ] vectorTM
 961     -- variable res : fsvec_x (0 to vec'length-1);
 962     shiftrVar =
 963      AST.VarDec resId
 964             (AST.SubtypeIn vectorTM
 965               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 966                [AST.ToRange (AST.PrimLit "0")
 967                         (AST.PrimName (AST.NAttribute $
 968                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 969                            (AST.PrimLit "1")) ]))
 970             Nothing
 971     -- res := tail(vec) & a
 972     shiftrExpr = AST.NSimple resId AST.:=
 973                   ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
 974                     [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
 975                   (AST.PrimName (AST.NSimple aPar)))
 976
 977     shiftrRet = AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
 978     nullSpec = AST.Function (mkVHDLExtId nullId) [AST.IfaceVarDec vecPar vectorTM] booleanTM
 979     -- return vec'length = 0
 980     nullExpr = AST.ReturnSm (Just $
 981                 AST.PrimName (AST.NAttribute $
 982                   AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:=:
 983                     AST.PrimLit "0")
 984     rotlSpec = AST.Function (mkVHDLExtId rotlId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
 985     -- variable res : fsvec_x (0 to vec'length-1);
 986     rotlVar =
 987      AST.VarDec resId
 988             (AST.SubtypeIn vectorTM
 989               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
 990                [AST.ToRange (AST.PrimLit "0")
 991                         (AST.PrimName (AST.NAttribute $
 992                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
 993                            (AST.PrimLit "1")) ]))
 994             Nothing
 995     -- if null(vec) then res := vec else res := last(vec) & init(vec)
 996     rotlExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
 997                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
 998                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
 999                         []
1000                         (Just $ AST.Else [rotlExprRet])
1001       where rotlExprRet =
1002                 AST.NSimple resId AST.:=
1003                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId lastId))
1004                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1005                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId initId))
1006                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1007     rotlRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1008     rotrSpec = AST.Function (mkVHDLExtId rotrId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1009     -- variable res : fsvec_x (0 to vec'length-1);
1010     rotrVar =
1011      AST.VarDec resId
1012             (AST.SubtypeIn vectorTM
1013               (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1014                [AST.ToRange (AST.PrimLit "0")
1015                         (AST.PrimName (AST.NAttribute $
1016                           AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1017                            (AST.PrimLit "1")) ]))
1018             Nothing
1019     -- if null(vec) then res := vec else res := tail(vec) & head(vec)
1020     rotrExpr = AST.IfSm (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId nullId))
1021                           [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)])
1022                         [AST.NSimple resId AST.:= (AST.PrimName $ AST.NSimple vecPar)]
1023                         []
1024                         (Just $ AST.Else [rotrExprRet])
1025       where rotrExprRet =
1026                 AST.NSimple resId AST.:=
1027                       ((AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId tailId))
1028                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]) AST.:&:
1029                       (AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLExtId headId))
1030                         [Nothing AST.:=>: AST.ADExpr (AST.PrimName $ AST.NSimple vecPar)]))
1031     rotrRet =  AST.ReturnSm (Just $ AST.PrimName $ AST.NSimple resId)
1032     reverseSpec = AST.Function (mkVHDLExtId reverseId) [AST.IfaceVarDec vecPar vectorTM] vectorTM
1033     reverseVar =
1034       AST.VarDec resId
1035              (AST.SubtypeIn vectorTM
1036                (Just $ AST.ConstraintIndex $ AST.IndexConstraint
1037                 [AST.ToRange (AST.PrimLit "0")
1038                          (AST.PrimName (AST.NAttribute $
1039                            AST.AttribName (AST.NSimple vecPar) (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1040                             (AST.PrimLit "1")) ]))
1041              Nothing
1042     -- for i in 0 to res'range loop
1043     --   res(vec'length-i-1) := vec(i);
1044     -- end loop;
1045     reverseFor =
1046        AST.ForSM iId (AST.AttribRange $ AST.AttribName (AST.NSimple resId) (AST.NSimple $ rangeId) Nothing) [reverseAssign]
1047     -- res(vec'length-i-1) := vec(i);
1048     reverseAssign = AST.NIndexed (AST.IndexedName (AST.NSimple resId) [destExp]) AST.:=
1049       (AST.PrimName $ AST.NIndexed (AST.IndexedName (AST.NSimple vecPar)
1050                            [AST.PrimName $ AST.NSimple iId]))
1051         where destExp = AST.PrimName (AST.NAttribute $ AST.AttribName (AST.NSimple vecPar)
1052                                    (AST.NSimple $ mkVHDLBasicId lengthId) Nothing) AST.:-:
1053                         AST.PrimName (AST.NSimple iId) AST.:-:
1054                         (AST.PrimLit "1")
1055     -- return res;
1056     reverseRet = AST.ReturnSm (Just $ AST.PrimName (AST.NSimple resId))
1057
1058
1059 -----------------------------------------------------------------------------
1060 -- A table of builtin functions
1061 -----------------------------------------------------------------------------
1062
1063 -- | The builtin functions we support. Maps a name to an argument count and a
1064 -- builder function.
1065 globalNameTable :: NameTable
1066 globalNameTable = Map.fromList
1067   [ (exId             , (2, genFCall True          ) )
1068   , (replaceId        , (3, genFCall False          ) )
1069   , (headId           , (1, genFCall True           ) )
1070   , (lastId           , (1, genFCall True           ) )
1071   , (tailId           , (1, genFCall False          ) )
1072   , (initId           , (1, genFCall False          ) )
1073   , (takeId           , (2, genFCall False          ) )
1074   , (dropId           , (2, genFCall False          ) )
1075   , (selId            , (4, genFCall False          ) )
1076   , (plusgtId         , (2, genFCall False          ) )
1077   , (ltplusId         , (2, genFCall False          ) )
1078   , (plusplusId       , (2, genFCall False          ) )
1079   , (mapId            , (2, genMap                  ) )
1080   , (zipWithId        , (3, genZipWith              ) )
1081   , (foldlId          , (3, genFoldl                ) )
1082   , (foldrId          , (3, genFoldr                ) )
1083   , (zipId            , (2, genZip                  ) )
1084   , (unzipId          , (1, genUnzip                ) )
1085   , (shiftlId         , (2, genFCall False          ) )
1086   , (shiftrId         , (2, genFCall False          ) )
1087   , (rotlId           , (1, genFCall False          ) )
1088   , (rotrId           , (1, genFCall False          ) )
1089   , (concatId         , (1, genConcat               ) )
1090   , (reverseId        , (1, genFCall False          ) )
1091   , (iteratenId       , (3, genIteraten             ) )
1092   , (iterateId        , (2, genIterate              ) )
1093   , (generatenId      , (3, genGeneraten            ) )
1094   , (generateId       , (2, genGenerate             ) )
1095   , (emptyId          , (0, genFCall False          ) )
1096   , (singletonId      , (1, genFCall False          ) )
1097   , (copynId          , (2, genFCall False          ) )
1098   , (copyId           , (1, genCopy                 ) )
1099   , (lengthTId        , (1, genFCall False          ) )
1100   , (nullId           , (1, genFCall False          ) )
1101   , (hwxorId          , (2, genOperator2 AST.Xor    ) )
1102   , (hwandId          , (2, genOperator2 AST.And    ) )
1103   , (hworId           , (2, genOperator2 AST.Or     ) )
1104   , (hwnotId          , (1, genOperator1 AST.Not    ) )
1105   , (plusId           , (2, genOperator2 (AST.:+:)  ) )
1106   , (timesId          , (2, genOperator2 (AST.:*:)  ) )
1107   , (negateId         , (1, genNegation             ) )
1108   , (minusId          , (2, genOperator2 (AST.:-:)  ) )
1109   , (fromSizedWordId  , (1, genFromSizedWord        ) )
1110   , (fromIntegerId    , (1, genFromInteger          ) )
1111   , (resizeId         , (1, genResize               ) )
1112   , (sizedIntId       , (1, genSizedInt             ) )
1113   , (tfvecId          , (1, genTFVec                ) )
1114   , (minimumId        , (2, error $ "\nFunction name: \"minimum\" is used internally, use another name"))
1115   ]