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