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