+{-# LANGUAGE PackageImports #-}
+
module Generate where
-- Standard modules
import qualified Data.Map as Map
import qualified Maybe
import qualified Data.Either as Either
+import qualified Control.Monad.Trans.State as State
+import qualified "transformers" Control.Monad.Identity as Identity
import Data.Accessor
+import Data.Accessor.MonadState as MonadState
import Debug.Trace
-- ForSyDe
-import qualified ForSyDe.Backend.VHDL.AST as AST
+import qualified Language.VHDL.AST as AST
-- GHC API
import CoreSyn
import Type
import qualified Var
import qualified IdInfo
+import qualified Literal
+import qualified Name
+import qualified TyCon
-- Local imports
import Constants
-- | A function to wrap a builder-like function that expects its arguments to
-- be expressions.
-genExprArgs ::
- (dst -> func -> [AST.Expr] -> res)
- -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
-genExprArgs wrap dst func args = wrap dst func args'
- where args' = map (either (varToVHDLExpr.exprToVar) id) args
-
+genExprArgs wrap dst func args = do
+ args' <- eitherCoreOrExprArgs args
+ wrap dst func args'
+
+eitherCoreOrExprArgs :: [Either CoreSyn.CoreExpr AST.Expr] -> VHDLSession [AST.Expr]
+eitherCoreOrExprArgs args = mapM (Either.either ((MonadState.lift vsType) . varToVHDLExpr . exprToVar) return) args
+
-- | A function to wrap a builder-like function that expects its arguments to
-- be variables.
genVarArgs ::
-- Check (rather crudely) that all arguments are CoreExprs
(exprargs, []) = Either.partitionEithers args
+-- | A function to wrap a builder-like function that expects its arguments to
+-- be Literals
+genLitArgs ::
+ (dst -> func -> [Literal.Literal] -> res)
+ -> (dst -> func -> [Either CoreSyn.CoreExpr AST.Expr] -> res)
+genLitArgs wrap dst func args = wrap dst func args'
+ where
+ args' = map exprToLit litargs
+ -- FIXME: Check if we were passed an CoreSyn.App
+ litargs = concat (map getLiterals exprargs)
+ (exprargs, []) = Either.partitionEithers args
+
-- | A function to wrap a builder-like function that produces an expression
-- and expects it to be assigned to the destination.
genExprRes ::
genOperator1' :: (AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genOperator1' op _ f [arg] = return $ op arg
+-- | Generate a unary operator application
+genNegation :: BuiltinBuilder
+genNegation = genVarArgs $ genExprRes genNegation'
+genNegation' :: dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation' _ f [arg] = do
+ arg1 <- MonadState.lift vsType $ varToVHDLExpr arg
+ let ty = Var.varType arg
+ let (tycon, args) = Type.splitTyConApp ty
+ let name = Name.getOccString (TyCon.tyConName tycon)
+ case name of
+ "SizedInt" -> return $ AST.Neg arg1
+ otherwise -> error $ "\nGenerate.genNegation': Negation allowed for type: " ++ show name
+
-- | Generate a function call from the destination binder, function name and a
-- list of expressions (its arguments)
genFCall :: Bool -> BuiltinBuilder
genFCall' switch (Left res) f args = do
let fname = varToString f
let el_ty = if switch then (Var.varType res) else ((tfvec_elem . Var.varType) res)
- id <- vectorFunId el_ty fname
+ id <- MonadState.lift vsType $ vectorFunId el_ty fname
return $ AST.PrimFCall $ AST.FCall (AST.NSimple id) $
map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
genFCall' _ (Right name) _ _ = error $ "\nGenerate.genFCall': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+genFromSizedWord :: BuiltinBuilder
+genFromSizedWord = genExprArgs $ genExprRes genFromSizedWord'
+genFromSizedWord' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genFromSizedWord' (Left res) f args = do
+ let fname = varToString f
+ return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId toIntegerId)) $
+ map (\exp -> Nothing AST.:=>: AST.ADExpr exp) args
+genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+genResize :: BuiltinBuilder
+genResize = genExprArgs $ genExprRes genResize'
+genResize' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
+genResize' (Left res) f [arg] = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId resizeId))
+ [Nothing AST.:=>: AST.ADExpr arg, Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+genResize' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+-- FIXME: I'm calling genLitArgs which is very specific function,
+-- which needs to be fixed as well
+genFromInteger :: BuiltinBuilder
+genFromInteger = genLitArgs $ genExprRes genFromInteger'
+genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
+genFromInteger' (Left res) f lits = do {
+ ; let { ty = Var.varType res
+ ; (tycon, args) = Type.splitTyConApp ty
+ ; name = Name.getOccString (TyCon.tyConName tycon)
+ } ;
+ ; len <- case name of
+ "SizedInt" -> MonadState.lift vsType $ tfp_to_int (sized_int_len_ty ty)
+ "SizedWord" -> MonadState.lift vsType $ tfp_to_int (sized_word_len_ty ty)
+ ; let fname = case name of "SizedInt" -> toSignedId ; "SizedWord" -> toUnsignedId
+ ; return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+ [Nothing AST.:=>: AST.ADExpr (AST.PrimLit (show (last lits))), Nothing AST.:=>: AST.ADExpr( AST.PrimLit (show len))]
+ }
+
+genFromInteger' (Right name) _ _ = error $ "\nGenerate.genFromInteger': Cannot generate builtin function call assigned to a VHDLName: " ++ show name
+
+
-- | Generate a generate statement for the builtin function "map"
genMap :: BuiltinBuilder
-genMap (Left res) f [Left mapped_f, Left (Var arg)] =
+genMap (Left res) f [Left mapped_f, Left (Var arg)] = do {
-- mapped_f must be a CoreExpr (since we can't represent functions as VHDL
-- expressions). arg must be a CoreExpr (and should be a CoreSyn.Var), since
-- we must index it (which we couldn't if it was a VHDL Expr, since only
-- VHDLNames can be indexed).
- let
- -- Setup the generate scheme
- len = (tfvec_len . Var.varType) res
- -- TODO: Use something better than varToString
- label = mkVHDLExtId ("mapVector" ++ (varToString res))
- n_id = mkVHDLBasicId "n"
- n_expr = idToVHDLExpr n_id
- range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- genScheme = AST.ForGn n_id range
-
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- resname = mkIndexedName (varToVHDLName res) n_expr
- argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- in do
- let (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
- let valargs = get_val_args (Var.varType real_f) already_mapped_args
- app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("mapVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; (CoreSyn.Var real_f, already_mapped_args) = CoreSyn.collectArgs mapped_f
+ ; valargs = get_val_args (Var.varType real_f) already_mapped_args
+ } ;
+ ; app_concsms <- genApplication (Right resname) real_f (map Left valargs ++ [Right argexpr])
-- Return the generate statement
- return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ }
genMap' (Right name) _ _ = error $ "\nGenerate.genMap': Cannot generate map function call assigned to a VHDLName: " ++ show name
genZipWith :: BuiltinBuilder
genZipWith = genVarArgs genZipWith'
genZipWith' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genZipWith' (Left res) f args@[zipped_f, arg1, arg2] =
- let
- -- Setup the generate scheme
- len = (tfvec_len . Var.varType) res
- -- TODO: Use something better than varToString
- label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
- n_id = mkVHDLBasicId "n"
- n_expr = idToVHDLExpr n_id
- range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- genScheme = AST.ForGn n_id range
-
- -- Create the content of the generate statement: Applying the zipped_f to
- -- each of the elements in arg1 and arg2, storing to each element in res
- resname = mkIndexedName (varToVHDLName res) n_expr
- argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- in do
- app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
+genZipWith' (Left res) f args@[zipped_f, arg1, arg2] = do {
+ -- Setup the generate scheme
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipWithVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the zipped_f to
+ -- each of the elements in arg1 and arg2, storing to each element in res
+ ; resname = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; app_concsms <- genApplication (Right resname) zipped_f [Right argexpr1, Right argexpr2]
-- Return the generate functions
- return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] app_concsms]
+ }
genFoldl :: BuiltinBuilder
genFoldl = genFold True
genFold :: Bool -> BuiltinBuilder
genFold left = genVarArgs (genFold' left)
+
genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genFold' left res f args@[folded_f , start ,vec]= do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty (Var.varType vec))
+ genFold'' len left res f args
+
+genFold'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-- Special case for an empty input vector, just assign start to res
-genFold' left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) (varToVHDLExpr start)]
- where len = (tfvec_len . Var.varType) vec
-genFold' left (Left res) f [folded_f, start, vec] = do
+genFold'' len left (Left res) _ [_, start, vec] | len == 0 = do
+ arg <- MonadState.lift vsType $ varToVHDLExpr start
+ return [mkUncondAssign (Left res) arg]
+
+genFold'' len left (Left res) f [folded_f, start, vec] = do
+ -- The vector length
+ --len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
-- evec is (TFVec n), so it still needs an element type
let (nvec, _) = splitAppTy (Var.varType vec)
-- Put the type of the start value in nvec, this will be the type of our
-- temporary vector
let tmp_ty = Type.mkAppTy nvec (Var.varType start)
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty
+ tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("foldlVector" ++ (varToString vec))
let block_label = mkVHDLExtId ("foldlVector" ++ (varToString start))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
return [AST.CSBSm block]
where
- -- The vector length
- len = (tfvec_len . Var.varType) vec
-- An id for the counter
n_id = mkVHDLBasicId "n"
n_cur = idToVHDLExpr n_id
-- An expression for previous n
n_prev = if left then (n_cur AST.:-: (AST.PrimLit "1"))
else (n_cur AST.:+: (AST.PrimLit "1"))
- -- An expression for len-1
- len_min_expr = (AST.PrimLit $ show (len-1))
-- An id for the tmp result vector
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Generate parts of the fold
genFirstCell, genOtherCell :: VHDLSession AST.GenerateSm
genFirstCell = do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
let cond_label = mkVHDLExtId "firstcell"
-- if n == 0 or n == len-1
let cond_scheme = AST.IfGn $ n_cur AST.:=: (if left then (AST.PrimLit "0")
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
- let argexpr1 = varToVHDLExpr start
+ argexpr1 <- MonadState.lift vsType $ varToVHDLExpr start
-- Input from vec[current n]
let argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName vec) n_cur
app_concsms <- genApplication (Right resname) folded_f ( if left then
return $ AST.GenerateSm cond_label cond_scheme [] app_concsms
genOtherCell = do
+ len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) vec
let cond_label = mkVHDLExtId "othercell"
-- if n > 0 or n < len-1
let cond_scheme = AST.IfGn $ n_cur AST.:/=: (if left then (AST.PrimLit "0")
genZip :: BuiltinBuilder
genZip = genVarArgs genZip'
genZip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genZip' (Left res) f args@[arg1, arg2] =
- let
+genZip' (Left res) f args@[arg1, arg2] = do {
-- Setup the generate scheme
- len = (tfvec_len . Var.varType) res
- -- TODO: Use something better than varToString
- label = mkVHDLExtId ("zipVector" ++ (varToString res))
- n_id = mkVHDLBasicId "n"
- n_expr = idToVHDLExpr n_id
- range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- genScheme = AST.ForGn n_id range
- resname' = mkIndexedName (varToVHDLName res) n_expr
- argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
- argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
- in do
- labels <- getFieldLabels (tfvec_elem (Var.varType res))
- let resnameA = mkSelectedName resname' (labels!!0)
- let resnameB = mkSelectedName resname' (labels!!1)
- let resA_assign = mkUncondAssign (Right resnameA) argexpr1
- let resB_assign = mkUncondAssign (Right resnameB) argexpr2
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) res
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("zipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = mkIndexedName (varToVHDLName res) n_expr
+ ; argexpr1 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg1) n_expr
+ ; argexpr2 = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg2) n_expr
+ } ;
+ ; labels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType res))
+ ; let { resnameA = mkSelectedName resname' (labels!!0)
+ ; resnameB = mkSelectedName resname' (labels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexpr1
+ ; resB_assign = mkUncondAssign (Right resnameB) argexpr2
+ } ;
-- Return the generate functions
- return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
-- | Generate a generate statement for the builtin function "unzip"
genUnzip :: BuiltinBuilder
genUnzip = genVarArgs genUnzip'
genUnzip' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genUnzip' (Left res) f args@[arg] =
- let
+genUnzip' (Left res) f args@[arg] = do {
-- Setup the generate scheme
- len = (tfvec_len . Var.varType) arg
+ ; len <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
-- TODO: Use something better than varToString
- label = mkVHDLExtId ("unzipVector" ++ (varToString res))
- n_id = mkVHDLBasicId "n"
- n_expr = idToVHDLExpr n_id
- range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
- genScheme = AST.ForGn n_id range
- resname' = varToVHDLName res
- argexpr' = mkIndexedName (varToVHDLName arg) n_expr
- in do
- reslabels <- getFieldLabels (Var.varType res)
- arglabels <- getFieldLabels (tfvec_elem (Var.varType arg))
- let resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
- let resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
- let argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
- let argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
- let resA_assign = mkUncondAssign (Right resnameA) argexprA
- let resB_assign = mkUncondAssign (Right resnameB) argexprB
+ ; let { label = mkVHDLExtId ("unzipVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len-1))
+ ; genScheme = AST.ForGn n_id range
+ ; resname' = varToVHDLName res
+ ; argexpr' = mkIndexedName (varToVHDLName arg) n_expr
+ } ;
+ ; reslabels <- MonadState.lift vsType $ getFieldLabels (Var.varType res)
+ ; arglabels <- MonadState.lift vsType $ getFieldLabels (tfvec_elem (Var.varType arg))
+ ; let { resnameA = mkIndexedName (mkSelectedName resname' (reslabels!!0)) n_expr
+ ; resnameB = mkIndexedName (mkSelectedName resname' (reslabels!!1)) n_expr
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!0)
+ ; argexprB = vhdlNameToVHDLExpr $ mkSelectedName argexpr' (arglabels!!1)
+ ; resA_assign = mkUncondAssign (Right resnameA) argexprA
+ ; resB_assign = mkUncondAssign (Right resnameB) argexprB
+ } ;
-- Return the generate functions
- return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [resA_assign,resB_assign]]
+ }
genCopy :: BuiltinBuilder
genCopy = genVarArgs genCopy'
genConcat :: BuiltinBuilder
genConcat = genVarArgs genConcat'
genConcat' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-genConcat' (Left res) f args@[arg] =
- let
+genConcat' (Left res) f args@[arg] = do {
-- Setup the generate scheme
- len1 = (tfvec_len . Var.varType) arg
- (_, nvec) = splitAppTy (Var.varType arg)
- len2 = tfvec_len nvec
- -- TODO: Use something better than varToString
- label = mkVHDLExtId ("concatVector" ++ (varToString res))
- n_id = mkVHDLBasicId "n"
- n_expr = idToVHDLExpr n_id
- fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
- genScheme = AST.ForGn n_id range
- -- Create the content of the generate statement: Applying the mapped_f to
- -- each of the elements in arg, storing to each element in res
- toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
- range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
- resname = vecSlice fromRange toRange
- argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
- out_assign = mkUncondAssign (Right resname) argexpr
- in
+ ; len1 <- MonadState.lift vsType $ tfp_to_int $ (tfvec_len_ty . Var.varType) arg
+ ; let (_, nvec) = splitAppTy (Var.varType arg)
+ ; len2 <- MonadState.lift vsType $ tfp_to_int $ tfvec_len_ty nvec
+ -- TODO: Use something better than varToString
+ ; let { label = mkVHDLExtId ("concatVector" ++ (varToString res))
+ ; n_id = mkVHDLBasicId "n"
+ ; n_expr = idToVHDLExpr n_id
+ ; fromRange = n_expr AST.:*: (AST.PrimLit $ show len2)
+ ; genScheme = AST.ForGn n_id range
+ -- Create the content of the generate statement: Applying the mapped_f to
+ -- each of the elements in arg, storing to each element in res
+ ; toRange = (n_expr AST.:*: (AST.PrimLit $ show len2)) AST.:+: (AST.PrimLit $ show (len2-1))
+ ; range = AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (len1-1))
+ ; resname = vecSlice fromRange toRange
+ ; argexpr = vhdlNameToVHDLExpr $ mkIndexedName (varToVHDLName arg) n_expr
+ ; out_assign = mkUncondAssign (Right resname) argexpr
+ } ;
-- Return the generate statement
- return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+ ; return [AST.CSGSm $ AST.GenerateSm label genScheme [] [out_assign]]
+ }
where
vecSlice init last = AST.NSlice (AST.SliceName (varToVHDLName res)
(AST.ToRange init last))
genIterateOrGenerate :: Bool -> BuiltinBuilder
genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
+
genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate' iter (Left res) f args = do
+ len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ genIterateOrGenerate'' len iter (Left res) f args
+
+genIterateOrGenerate'' :: Int -> Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
-- Special case for an empty input vector, just assign start to res
-genIterateOrGenerate' iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
- where len = (tfvec_len . Var.varType) res
-genIterateOrGenerate' iter (Left res) f [app_f, start] = do
+genIterateOrGenerate'' len iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+
+genIterateOrGenerate'' len iter (Left res) f [app_f, start] = do
+ -- The vector length
+ -- len <- MonadState.lift vsType $ tfp_to_int ((tfvec_len_ty . Var.varType) res)
+ -- An expression for len-1
+ let len_min_expr = (AST.PrimLit $ show (len-1))
-- -- evec is (TFVec n), so it still needs an element type
-- let (nvec, _) = splitAppTy (Var.varType vec)
-- -- Put the type of the start value in nvec, this will be the type of our
-- -- temporary vector
let tmp_ty = Var.varType res
let error_msg = "\nGenerate.genFold': Can not construct temp vector for element type: " ++ pprString tmp_ty
- tmp_vhdl_ty <- vhdl_ty error_msg tmp_ty
+ tmp_vhdl_ty <- MonadState.lift vsType $ vhdl_ty error_msg tmp_ty
-- Setup the generate scheme
let gen_label = mkVHDLExtId ("iterateVector" ++ (varToString start))
let block_label = mkVHDLExtId ("iterateVector" ++ (varToString res))
let block = AST.BlockSm block_label [] (AST.PMapAspect []) [tmp_dec] [AST.CSGSm gen_sm, out_assign]
return [AST.CSBSm block]
where
- -- The vector length
- len = (tfvec_len . Var.varType) res
-- An id for the counter
n_id = mkVHDLBasicId "n"
n_cur = idToVHDLExpr n_id
-- An expression for previous n
n_prev = n_cur AST.:-: (AST.PrimLit "1")
- -- An expression for len-1
- len_min_expr = (AST.PrimLit $ show (len-1))
-- An id for the tmp result vector
tmp_id = mkVHDLBasicId "tmp"
tmp_name = AST.NSimple tmp_id
-- Output to tmp[current n]
let resname = mkIndexedName tmp_name n_cur
-- Input from start
- let argexpr = varToVHDLExpr start
+ argexpr <- MonadState.lift vsType $ varToVHDLExpr start
let startassign = mkUncondAssign (Right resname) argexpr
app_concsms <- genApplication (Right resname) app_f [Right argexpr]
-- Return the conditional generate part
-> CoreSyn.CoreBndr -- ^ The function to apply
-> [Either CoreSyn.CoreExpr AST.Expr] -- ^ The arguments to apply
-> VHDLSession [AST.ConcSm] -- ^ The resulting concurrent statements
-genApplication dst f args =
- case Var.globalIdVarDetails f of
- IdInfo.DataConWorkId dc -> case dst of
- -- It's a datacon. Create a record from its arguments.
- Left bndr -> do
- -- We have the bndr, so we can get at the type
- labels <- getFieldLabels (Var.varType bndr)
- return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
- where
- mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
- mkassign label arg =
- let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
- mkUncondAssign (Right sel_name) arg
- Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
- IdInfo.VanillaGlobal -> do
- -- It's a global value imported from elsewhere. These can be builtin
- -- functions. Look up the function name in the name table and execute
- -- the associated builder if there is any and the argument count matches
- -- (this should always be the case if it typechecks, but just to be
- -- sure...).
- case (Map.lookup (varToString f) globalNameTable) of
- Just (arg_count, builder) ->
- if length args == arg_count then
- builder dst f args
- else
- error $ "\nGenerate.genApplication: Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
- Nothing -> error $ "\nGenerate.genApplication: Using function from another module that is not a known builtin: " ++ pprString f
- IdInfo.NotGlobalId -> do
+genApplication dst f args = do
+ case Var.isGlobalId f of
+ False -> do
signatures <- getA vsSignatures
-- This is a local id, so it should be a function whose definition we
-- have and which can be turned into a component instantiation.
- let
- signature = Maybe.fromMaybe
- (error $ "\nGenerate.genApplication: Using function '" ++ (varToString f) ++ "' without signature? This should not happen!")
- (Map.lookup f signatures)
- entity_id = ent_id signature
- -- TODO: Using show here isn't really pretty, but we'll need some
- -- unique-ish value...
- label = "comp_ins_" ++ (either show prettyShow) dst
- portmaps = mkAssocElems (map (either exprToVHDLExpr id) args) ((either varToVHDLName id) dst) signature
- in
+ case (Map.lookup f signatures) of
+ Just signature -> do
+ args' <- eitherCoreOrExprArgs args
+ -- We have a signature, this is a top level binding. Generate a
+ -- component instantiation.
+ let entity_id = ent_id signature
+ -- TODO: Using show here isn't really pretty, but we'll need some
+ -- unique-ish value...
+ let label = "comp_ins_" ++ (either show prettyShow) dst
+ let portmaps = mkAssocElems args' ((either varToVHDLName id) dst) signature
return [mkComponentInst label entity_id portmaps]
- details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
+ Nothing -> do
+ -- No signature, so this must be a local variable reference. It
+ -- should have a representable type (and thus, no arguments) and a
+ -- signal should be generated for it. Just generate an
+ -- unconditional assignment here.
+ f' <- MonadState.lift vsType $ varToVHDLExpr f
+ return $ [mkUncondAssign dst f']
+ True ->
+ case Var.idDetails f of
+ IdInfo.DataConWorkId dc -> case dst of
+ -- It's a datacon. Create a record from its arguments.
+ Left bndr -> do
+ -- We have the bndr, so we can get at the type
+ labels <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
+ args' <- eitherCoreOrExprArgs args
+ return $ zipWith mkassign labels $ args'
+ where
+ mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
+ mkassign label arg =
+ let sel_name = mkSelectedName ((either varToVHDLName id) dst) label in
+ mkUncondAssign (Right sel_name) arg
+ Right _ -> error $ "\nGenerate.genApplication: Can't generate dataconstructor application without an original binder"
+ IdInfo.VanillaId -> do
+ -- It's a global value imported from elsewhere. These can be builtin
+ -- functions. Look up the function name in the name table and execute
+ -- the associated builder if there is any and the argument count matches
+ -- (this should always be the case if it typechecks, but just to be
+ -- sure...).
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(VanillaGlobal): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication(VanillaGlobal): Using function from another module that is not a known builtin: " ++ pprString f
+ IdInfo.ClassOpId cls -> do
+ -- FIXME: Not looking for what instance this class op is called for
+ -- Is quite stupid of course.
+ case (Map.lookup (varToString f) globalNameTable) of
+ Just (arg_count, builder) ->
+ if length args == arg_count then
+ builder dst f args
+ else
+ error $ "\nGenerate.genApplication(ClassOpId): Incorrect number of arguments to builtin function: " ++ pprString f ++ " Args: " ++ show args
+ Nothing -> error $ "\nGenerate.genApplication(ClassOpId): Using function from another module that is not a known builtin: " ++ pprString f
+ details -> error $ "\nGenerate.genApplication: Calling unsupported function " ++ pprString f ++ " with GlobalIdDetails " ++ pprString details
-----------------------------------------------------------------------------
-- Functions to generate functions dealing with vectors.
-- Returns the VHDLId of the vector function with the given name for the given
-- element type. Generates -- this function if needed.
-vectorFunId :: Type.Type -> String -> VHDLSession AST.VHDLId
+vectorFunId :: Type.Type -> String -> TypeSession AST.VHDLId
vectorFunId el_ty fname = do
let error_msg = "\nGenerate.vectorFunId: Can not construct vector function for element: " ++ pprString el_ty
elemTM <- vhdl_ty error_msg el_ty
, (hwandId , (2, genOperator2 AST.And ) )
, (hworId , (2, genOperator2 AST.Or ) )
, (hwnotId , (1, genOperator1 AST.Not ) )
+ , (plusId , (2, genOperator2 (AST.:+:) ) )
+ , (timesId , (2, genOperator2 (AST.:*:) ) )
+ , (negateId , (1, genNegation ) )
+ , (minusId , (2, genOperator2 (AST.:-:) ) )
+ , (fromSizedWordId , (1, genFromSizedWord ) )
+ , (fromIntegerId , (1, genFromInteger ) )
+ , (resizeId , (1, genResize ) )
]
projects / matthijs / master-project / cλash.git / blobdiff