Generate.hs

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