+{-# 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
-- | A function to wrap a builder-like function that expects its arguments to
-- be expressions.
genExprArgs ::
- (dst -> func -> [AST.Expr] -> res)
+ TypeState
+ -> (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 ty_state wrap dst func args = wrap dst func args'
+ where args' = map (either ((varToVHDLExpr ty_state).exprToVar) id) args
-- | A function to wrap a builder-like function that expects its arguments to
-- be variables.
-- | Generate a binary operator application. The first argument should be a
-- constructor from the AST.Expr type, e.g. AST.And.
-genOperator2 :: (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator2 op = genExprArgs $ genExprRes (genOperator2' op)
+genOperator2 :: TypeState -> (AST.Expr -> AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator2 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator2' op)
genOperator2' :: (AST.Expr -> AST.Expr -> AST.Expr) -> dst -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genOperator2' op _ f [arg1, arg2] = return $ op arg1 arg2
-- | Generate a unary operator application
-genOperator1 :: (AST.Expr -> AST.Expr) -> BuiltinBuilder
-genOperator1 op = genExprArgs $ genExprRes (genOperator1' op)
+genOperator1 :: TypeState -> (AST.Expr -> AST.Expr) -> BuiltinBuilder
+genOperator1 ty_state op = (genExprArgs ty_state) $ genExprRes (genOperator1' op)
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] = return $ op (varToVHDLExpr arg)
+genNegation :: TypeState -> BuiltinBuilder
+genNegation ty_state = genVarArgs $ genExprRes (genNegation' ty_state)
+genNegation' :: TypeState -> dst -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession AST.Expr
+genNegation' ty_state _ f [arg] = return $ op ((varToVHDLExpr ty_state) arg)
where
ty = Var.varType arg
(tycon, args) = Type.splitTyConApp ty
-- | Generate a function call from the destination binder, function name and a
-- list of expressions (its arguments)
-genFCall :: Bool -> BuiltinBuilder
-genFCall switch = genExprArgs $ genExprRes (genFCall' switch)
+genFCall :: TypeState -> Bool -> BuiltinBuilder
+genFCall ty_state switch = (genExprArgs ty_state) $ genExprRes (genFCall' switch)
genFCall' :: Bool -> Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [AST.Expr] -> VHDLSession AST.Expr
genFCall' switch (Left res) f args = do
let fname = varToString f
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 :: TypeState -> BuiltinBuilder
+genFromSizedWord ty_state = (genExprArgs ty_state) $ 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
genFromInteger :: BuiltinBuilder
genFromInteger = genLitArgs $ genExprRes genFromInteger'
genFromInteger' :: Either CoreSyn.CoreBndr AST.VHDLName -> CoreSyn.CoreBndr -> [Literal.Literal] -> VHDLSession AST.Expr
-genFromInteger' (Left res) f lits =
- return $ AST.PrimFCall $ AST.FCall (AST.NSimple (mkVHDLBasicId fname))
+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))]
- where
- ty = Var.varType res
- (tycon, args) = Type.splitTyConApp ty
- name = Name.getOccString (TyCon.tyConName tycon)
- len = case name of
- "SizedInt" -> sized_int_len ty
- "SizedWord" -> sized_word_len ty
- fname = case name of
- "SizedInt" -> toSignedId
- "SizedWord" -> toUnsignedId
+ }
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
+genFoldl :: TypeState -> BuiltinBuilder
+genFoldl ty_state = genFold ty_state True
-genFoldr :: BuiltinBuilder
-genFoldr = genFold False
+genFoldr :: TypeState -> BuiltinBuilder
+genFoldr ty_state = genFold ty_state False
-genFold :: Bool -> BuiltinBuilder
-genFold left = genVarArgs (genFold' left)
-genFold' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genFold :: TypeState -> Bool -> BuiltinBuilder
+genFold ty_state left = genVarArgs (genFold' ty_state left)
+genFold' :: TypeState -> 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' ty_state left (Left res) _ [_, start, vec] | len == 0 = return [mkUncondAssign (Left res) ((varToVHDLExpr ty_state) start)]
+ where
+ len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) vec) ty_state
+
+genFold' ty_state 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
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
+ let argexpr1 = (varToVHDLExpr ty_state) 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 <- MonadState.lift vsType $ 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 <- 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
- 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))
-genIteraten :: BuiltinBuilder
-genIteraten dst f args = genIterate dst f (tail args)
+genIteraten :: TypeState -> BuiltinBuilder
+genIteraten ty_state dst f args = genIterate ty_state dst f (tail args)
-genIterate :: BuiltinBuilder
-genIterate = genIterateOrGenerate True
+genIterate :: TypeState -> BuiltinBuilder
+genIterate ty_state = genIterateOrGenerate ty_state True
-genGeneraten :: BuiltinBuilder
-genGeneraten dst f args = genGenerate dst f (tail args)
+genGeneraten :: TypeState -> BuiltinBuilder
+genGeneraten ty_state dst f args = genGenerate ty_state dst f (tail args)
-genGenerate :: BuiltinBuilder
-genGenerate = genIterateOrGenerate False
+genGenerate :: TypeState -> BuiltinBuilder
+genGenerate ty_state = genIterateOrGenerate ty_state False
-genIterateOrGenerate :: Bool -> BuiltinBuilder
-genIterateOrGenerate iter = genVarArgs (genIterateOrGenerate' iter)
-genIterateOrGenerate' :: Bool -> (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [Var.Var] -> VHDLSession [AST.ConcSm]
+genIterateOrGenerate :: TypeState -> Bool -> BuiltinBuilder
+genIterateOrGenerate ty_state iter = genVarArgs (genIterateOrGenerate' ty_state iter)
+genIterateOrGenerate' :: TypeState -> 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' ty_state iter (Left res) _ [app_f, start] | len == 0 = return [mkUncondAssign (Left res) (AST.PrimLit "\"\"")]
+ where len = State.evalState (tfp_to_int $ (tfvec_len_ty . Var.varType) res) ty_state
+genIterateOrGenerate' ty_state 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
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
+ let argexpr = (varToVHDLExpr ty_state) 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 =
+genApplication dst f args = do
+ ty_state <- getA vsType
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 <- MonadState.lift vsType $ getFieldLabels (Var.varType bndr)
- return $ zipWith mkassign labels $ map (either exprToVHDLExpr id) args
+ return $ zipWith mkassign labels $ map (either (exprToVHDLExpr ty_state) id) args
where
mkassign :: AST.VHDLId -> AST.Expr -> AST.ConcSm
mkassign label arg =
-- 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
+ case (Map.lookup (varToString f) (globalNameTable ty_state)) of
Just (arg_count, builder) ->
if length args == arg_count then
builder dst f args
-- 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
+ portmaps = mkAssocElems (map (either (exprToVHDLExpr ty_state) id) args) ((either varToVHDLName id) dst) signature
in
return [mkComponentInst label entity_id portmaps]
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
+ case (Map.lookup (varToString f) (globalNameTable ty_state)) of
Just (arg_count, builder) ->
if length args == arg_count then
builder dst f args
-- | The builtin functions we support. Maps a name to an argument count and a
-- builder function.
-globalNameTable :: NameTable
-globalNameTable = Map.fromList
- [ (exId , (2, genFCall False ) )
- , (replaceId , (3, genFCall False ) )
- , (headId , (1, genFCall True ) )
- , (lastId , (1, genFCall True ) )
- , (tailId , (1, genFCall False ) )
- , (initId , (1, genFCall False ) )
- , (takeId , (2, genFCall False ) )
- , (dropId , (2, genFCall False ) )
- , (selId , (4, genFCall False ) )
- , (plusgtId , (2, genFCall False ) )
- , (ltplusId , (2, genFCall False ) )
- , (plusplusId , (2, genFCall False ) )
- , (mapId , (2, genMap ) )
- , (zipWithId , (3, genZipWith ) )
- , (foldlId , (3, genFoldl ) )
- , (foldrId , (3, genFoldr ) )
- , (zipId , (2, genZip ) )
- , (unzipId , (1, genUnzip ) )
- , (shiftlId , (2, genFCall False ) )
- , (shiftrId , (2, genFCall False ) )
- , (rotlId , (1, genFCall False ) )
- , (rotrId , (1, genFCall False ) )
- , (concatId , (1, genConcat ) )
- , (reverseId , (1, genFCall False ) )
- , (iteratenId , (3, genIteraten ) )
- , (iterateId , (2, genIterate ) )
- , (generatenId , (3, genGeneraten ) )
- , (generateId , (2, genGenerate ) )
- , (emptyId , (0, genFCall False ) )
- , (singletonId , (1, genFCall False ) )
- , (copynId , (2, genFCall False ) )
- , (copyId , (1, genCopy ) )
- , (lengthTId , (1, genFCall False ) )
- , (nullId , (1, genFCall False ) )
- , (hwxorId , (2, genOperator2 AST.Xor ) )
- , (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 ) )
+globalNameTable :: TypeState -> NameTable
+globalNameTable ty_state = Map.fromList
+ [ (exId , (2, genFCall ty_state False ) )
+ , (replaceId , (3, genFCall ty_state False ) )
+ , (headId , (1, genFCall ty_state True ) )
+ , (lastId , (1, genFCall ty_state True ) )
+ , (tailId , (1, genFCall ty_state False ) )
+ , (initId , (1, genFCall ty_state False ) )
+ , (takeId , (2, genFCall ty_state False ) )
+ , (dropId , (2, genFCall ty_state False ) )
+ , (selId , (4, genFCall ty_state False ) )
+ , (plusgtId , (2, genFCall ty_state False ) )
+ , (ltplusId , (2, genFCall ty_state False ) )
+ , (plusplusId , (2, genFCall ty_state False ) )
+ , (mapId , (2, genMap ) )
+ , (zipWithId , (3, genZipWith ) )
+ , (foldlId , (3, genFoldl ty_state ) )
+ , (foldrId , (3, genFoldr ty_state ) )
+ , (zipId , (2, genZip ) )
+ , (unzipId , (1, genUnzip ) )
+ , (shiftlId , (2, genFCall ty_state False ) )
+ , (shiftrId , (2, genFCall ty_state False ) )
+ , (rotlId , (1, genFCall ty_state False ) )
+ , (rotrId , (1, genFCall ty_state False ) )
+ , (concatId , (1, genConcat ) )
+ , (reverseId , (1, genFCall ty_state False ) )
+ , (iteratenId , (3, genIteraten ty_state ) )
+ , (iterateId , (2, genIterate ty_state ) )
+ , (generatenId , (3, genGeneraten ty_state ) )
+ , (generateId , (2, genGenerate ty_state ) )
+ , (emptyId , (0, genFCall ty_state False ) )
+ , (singletonId , (1, genFCall ty_state False ) )
+ , (copynId , (2, genFCall ty_state False ) )
+ , (copyId , (1, genCopy ) )
+ , (lengthTId , (1, genFCall ty_state False ) )
+ , (nullId , (1, genFCall ty_state False ) )
+ , (hwxorId , (2, genOperator2 ty_state AST.Xor ) )
+ , (hwandId , (2, genOperator2 ty_state AST.And ) )
+ , (hworId , (2, genOperator2 ty_state AST.Or ) )
+ , (hwnotId , (1, genOperator1 ty_state AST.Not ) )
+ , (plusId , (2, genOperator2 ty_state (AST.:+:) ) )
+ , (timesId , (2, genOperator2 ty_state (AST.:*:) ) )
+ , (negateId , (1, genNegation ty_state ) )
+ , (minusId , (2, genOperator2 ty_state (AST.:-:) ) )
+ , (fromSizedWordId , (1, genFromSizedWord ty_state ) )
+ , (fromIntegerId , (1, genFromInteger ) )
]
import HsValueMap
import Pretty
import Normalize
-import Flatten
-import FlattenTypes
+-- import Flatten
+-- import FlattenTypes
import VHDLTypes
import qualified VHDL
makeVHDL :: String -> String -> Bool -> IO ()
makeVHDL filename name stateful = do
-- Load the module
- core <- loadModule filename
+ (core, env) <- loadModule filename
-- Translate to VHDL
- vhdl <- moduleToVHDL core [(name, stateful)]
+ vhdl <- moduleToVHDL env core [(name, stateful)]
-- Write VHDL to file
let dir = "./vhdl/" ++ name ++ "/"
prepareDir dir
listBindings :: String -> IO [()]
listBindings filename = do
- core <- loadModule filename
+ (core, env) <- loadModule filename
let binds = CoreSyn.flattenBinds $ cm_binds core
mapM (listBinding) binds
-- | Show the core structure of the given binds in the given file.
listBind :: String -> String -> IO ()
listBind filename name = do
- core <- loadModule filename
+ (core, env) <- loadModule filename
let [(b, expr)] = findBinds core [name]
putStr "\n"
putStr $ prettyShow expr
-- | Translate the binds with the given names from the given core module to
-- VHDL. The Bool in the tuple makes the function stateful (True) or
-- stateless (False).
-moduleToVHDL :: HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
-moduleToVHDL core list = do
+moduleToVHDL :: HscTypes.HscEnv -> HscTypes.CoreModule -> [(String, Bool)] -> IO [(AST.VHDLId, AST.DesignFile)]
+moduleToVHDL env core list = do
let (names, statefuls) = unzip list
let binds = map fst $ findBinds core names
-- Generate a UniqSupply
uniqSupply <- UniqSupply.mkSplitUniqSupply 'z'
-- Turn bind into VHDL
let all_bindings = (CoreSyn.flattenBinds $ cm_binds core)
- let normalized_bindings = normalizeModule uniqSupply all_bindings binds statefuls
- let vhdl = VHDL.createDesignFiles normalized_bindings
+ let (normalized_bindings, typestate) = normalizeModule env uniqSupply all_bindings binds statefuls
+ let vhdl = VHDL.createDesignFiles typestate normalized_bindings
mapM (putStr . render . ForSyDe.Backend.Ppr.ppr . snd) vhdl
--putStr $ "\n\nFinal session:\n" ++ prettyShow sess ++ "\n\n"
return vhdl
ForSyDe.Backend.VHDL.FileIO.writeDesignFile vhdl fname
-- | Loads the given file and turns it into a core module.
-loadModule :: String -> IO HscTypes.CoreModule
+loadModule :: String -> IO (HscTypes.CoreModule, HscTypes.HscEnv)
loadModule filename =
defaultErrorHandler defaultDynFlags $ do
runGhc (Just libdir) $ do
--load LoadAllTargets
--core <- GHC.compileToCoreSimplified "Adders.hs"
core <- GHC.compileToCoreModule filename
- return core
+ env <- GHC.getSession
+ return (core, env)
-- | Extracts the named binds from the given module.
findBinds :: HscTypes.CoreModule -> [String] -> [(CoreBndr, CoreExpr)]
-- | Flattens the given bind into the given signature and adds it to the
-- session. Then (recursively) finds any functions it uses and does the same
-- with them.
-flattenBind ::
- HsFunction -- The signature to flatten into
- -> (CoreBndr, CoreExpr) -- The bind to flatten
- -> TranslatorState ()
-
-flattenBind hsfunc bind@(var, expr) = do
- -- Flatten the function
- let flatfunc = flattenFunction hsfunc bind
- -- Propagate state variables
- let flatfunc' = propagateState hsfunc flatfunc
- -- Store the flat function in the session
- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
- -- Flatten any functions used
- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
- mapM_ resolvFunc used_hsfuncs
+-- flattenBind ::
+-- HsFunction -- The signature to flatten into
+-- -> (CoreBndr, CoreExpr) -- The bind to flatten
+-- -> TranslatorState ()
+--
+-- flattenBind hsfunc bind@(var, expr) = do
+-- -- Flatten the function
+-- let flatfunc = flattenFunction hsfunc bind
+-- -- Propagate state variables
+-- let flatfunc' = propagateState hsfunc flatfunc
+-- -- Store the flat function in the session
+-- modA tsFlatFuncs (Map.insert hsfunc flatfunc')
+-- -- Flatten any functions used
+-- let used_hsfuncs = Maybe.mapMaybe usedHsFunc (flat_defs flatfunc')
+-- mapM_ resolvFunc used_hsfuncs
-- | Decide which incoming state variables will become state in the
-- given function, and which will be propagate to other applied
-- functions.
-propagateState ::
- HsFunction
- -> FlatFunction
- -> FlatFunction
-
-propagateState hsfunc flatfunc =
- flatfunc {flat_defs = apps', flat_sigs = sigs'}
- where
- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
- states' = zip olds news
- -- Find all signals used by all sigdefs
- uses = concatMap sigDefUses (flat_defs flatfunc)
- -- Find all signals that are used more than once (is there a
- -- prettier way to do this?)
- multiple_uses = uses List.\\ (List.nub uses)
- -- Find the states whose "old state" signal is used only once
- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
- -- See if these single use states can be propagated
- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
- substate_sigs = concat substate_sigss
- -- Mark any propagated state signals as SigSubState
- sigs' = map
- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
- (flat_sigs flatfunc)
+-- propagateState ::
+-- HsFunction
+-- -> FlatFunction
+-- -> FlatFunction
+--
+-- propagateState hsfunc flatfunc =
+-- flatfunc {flat_defs = apps', flat_sigs = sigs'}
+-- where
+-- (olds, news) = unzip $ getStateSignals hsfunc flatfunc
+-- states' = zip olds news
+-- -- Find all signals used by all sigdefs
+-- uses = concatMap sigDefUses (flat_defs flatfunc)
+-- -- Find all signals that are used more than once (is there a
+-- -- prettier way to do this?)
+-- multiple_uses = uses List.\\ (List.nub uses)
+-- -- Find the states whose "old state" signal is used only once
+-- single_use_states = filter ((`notElem` multiple_uses) . fst) states'
+-- -- See if these single use states can be propagated
+-- (substate_sigss, apps') = unzip $ map (propagateState' single_use_states) (flat_defs flatfunc)
+-- substate_sigs = concat substate_sigss
+-- -- Mark any propagated state signals as SigSubState
+-- sigs' = map
+-- (\(id, info) -> (id, if id `elem` substate_sigs then info {sigUse = SigSubState} else info))
+-- (flat_sigs flatfunc)
-- | Propagate the state into a single function application.
-propagateState' ::
- [(SignalId, SignalId)]
- -- ^ TODO
- -> SigDef -- ^ The SigDef to process.
- -> ([SignalId], SigDef)
- -- ^ Any signal ids that should become substates,
- -- and the resulting application.
-
-propagateState' states def =
- if (is_FApp def) then
- (our_old ++ our_new, def {appFunc = hsfunc'})
- else
- ([], def)
- where
- hsfunc = appFunc def
- args = appArgs def
- res = appRes def
- our_states = filter our_state states
- -- A state signal belongs in this function if the old state is
- -- passed in, and the new state returned
- our_state (old, new) =
- any (old `Foldable.elem`) args
- && new `Foldable.elem` res
- (our_old, our_new) = unzip our_states
- -- Mark the result
- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
- res' = fmap (mark_state (zip our_new [0..])) zipped_res
- -- Mark the args
- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
-
- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
- mark_state states (id, use) =
- case lookup id states of
- Nothing -> use
- Just state_id -> State state_id
+-- propagateState' ::
+-- [(SignalId, SignalId)]
+-- -- ^ TODO
+-- -> SigDef -- ^ The SigDef to process.
+-- -> ([SignalId], SigDef)
+-- -- ^ Any signal ids that should become substates,
+-- -- and the resulting application.
+--
+-- propagateState' states def =
+-- if (is_FApp def) then
+-- (our_old ++ our_new, def {appFunc = hsfunc'})
+-- else
+-- ([], def)
+-- where
+-- hsfunc = appFunc def
+-- args = appArgs def
+-- res = appRes def
+-- our_states = filter our_state states
+-- -- A state signal belongs in this function if the old state is
+-- -- passed in, and the new state returned
+-- our_state (old, new) =
+-- any (old `Foldable.elem`) args
+-- && new `Foldable.elem` res
+-- (our_old, our_new) = unzip our_states
+-- -- Mark the result
+-- zipped_res = zipValueMaps res (hsFuncRes hsfunc)
+-- res' = fmap (mark_state (zip our_new [0..])) zipped_res
+-- -- Mark the args
+-- zipped_args = zipWith zipValueMaps args (hsFuncArgs hsfunc)
+-- args' = map (fmap (mark_state (zip our_old [0..]))) zipped_args
+-- hsfunc' = hsfunc {hsFuncArgs = args', hsFuncRes = res'}
+--
+-- mark_state :: [(SignalId, StateId)] -> (SignalId, HsValueUse) -> HsValueUse
+-- mark_state states (id, use) =
+-- case lookup id states of
+-- Nothing -> use
+-- Just state_id -> State state_id
-- | Returns pairs of signals that should be mapped to state in this function.
-getStateSignals ::
- HsFunction -- | The function to look at
- -> FlatFunction -- | The function to look at
- -> [(SignalId, SignalId)]
- -- | TODO The state signals. The first is the state number, the second the
- -- signal to assign the current state to, the last is the signal
- -- that holds the new state.
-
-getStateSignals hsfunc flatfunc =
- [(old_id, new_id)
- | (old_num, old_id) <- args
- , (new_num, new_id) <- res
- , old_num == new_num]
- where
- sigs = flat_sigs flatfunc
- -- Translate args and res to lists of (statenum, sigid)
- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
+-- getStateSignals ::
+-- HsFunction -- | The function to look at
+-- -> FlatFunction -- | The function to look at
+-- -> [(SignalId, SignalId)]
+-- -- | TODO The state signals. The first is the state number, the second the
+-- -- signal to assign the current state to, the last is the signal
+-- -- that holds the new state.
+--
+-- getStateSignals hsfunc flatfunc =
+-- [(old_id, new_id)
+-- | (old_num, old_id) <- args
+-- , (new_num, new_id) <- res
+-- , old_num == new_num]
+-- where
+-- sigs = flat_sigs flatfunc
+-- -- Translate args and res to lists of (statenum, sigid)
+-- args = concat $ zipWith stateList (hsFuncArgs hsfunc) (flat_args flatfunc)
+-- res = stateList (hsFuncRes hsfunc) (flat_res flatfunc)
-- | Find the given function, flatten it and add it to the session. Then
-- (recursively) do the same for any functions used.
-resolvFunc ::
- HsFunction -- | The function to look for
- -> TranslatorState ()
-
-resolvFunc hsfunc = do
- flatfuncmap <- getA tsFlatFuncs
- -- Don't do anything if there is already a flat function for this hsfunc or
- -- when it is a builtin function.
- Monad.unless (Map.member hsfunc flatfuncmap) $ do
- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
- -- New function, resolve it
- core <- getA tsCoreModule
- -- Find the named function
- let name = (hsFuncName hsfunc)
- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
- case bind of
- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
- Just b -> flattenBind hsfunc b
+-- resolvFunc ::
+-- HsFunction -- | The function to look for
+-- -> TranslatorState ()
+--
+-- resolvFunc hsfunc = do
+-- flatfuncmap <- getA tsFlatFuncs
+-- -- Don't do anything if there is already a flat function for this hsfunc or
+-- -- when it is a builtin function.
+-- Monad.unless (Map.member hsfunc flatfuncmap) $ do
+-- -- Not working with new builtins -- Monad.unless (elem hsfunc VHDL.builtin_hsfuncs) $ do
+-- -- New function, resolve it
+-- core <- getA tsCoreModule
+-- -- Find the named function
+-- let name = (hsFuncName hsfunc)
+-- let bind = findBind (CoreSyn.flattenBinds $ cm_binds core) name
+-- case bind of
+-- Nothing -> error $ "Couldn't find function " ++ name ++ " in current module."
+-- Just b -> flattenBind hsfunc b
-- | Translate a top level function declaration to a HsFunction. i.e., which
-- interface will be provided by this function. This function essentially
-- defines the "calling convention" for hardware models.
-mkHsFunction ::
- Var.Var -- ^ The function defined
- -> Type -- ^ The function type (including arguments!)
- -> Bool -- ^ Is this a stateful function?
- -> HsFunction -- ^ The resulting HsFunction
-
-mkHsFunction f ty stateful=
- HsFunction hsname hsargs hsres
- where
- hsname = getOccString f
- (arg_tys, res_ty) = Type.splitFunTys ty
- (hsargs, hsres) =
- if stateful
- then
- let
- -- The last argument must be state
- state_ty = last arg_tys
- state = useAsState (mkHsValueMap state_ty)
- -- All but the last argument are inports
- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
- hsargs = inports ++ [state]
- hsres = case splitTupleType res_ty of
- -- Result type must be a two tuple (state, ports)
- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
- then
- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
- else
- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
- in
- (hsargs, hsres)
- else
- -- Just use everything as a port
- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
+-- mkHsFunction ::
+-- Var.Var -- ^ The function defined
+-- -> Type -- ^ The function type (including arguments!)
+-- -> Bool -- ^ Is this a stateful function?
+-- -> HsFunction -- ^ The resulting HsFunction
+--
+-- mkHsFunction f ty stateful=
+-- HsFunction hsname hsargs hsres
+-- where
+-- hsname = getOccString f
+-- (arg_tys, res_ty) = Type.splitFunTys ty
+-- (hsargs, hsres) =
+-- if stateful
+-- then
+-- let
+-- -- The last argument must be state
+-- state_ty = last arg_tys
+-- state = useAsState (mkHsValueMap state_ty)
+-- -- All but the last argument are inports
+-- inports = map (useAsPort . mkHsValueMap)(init arg_tys)
+-- hsargs = inports ++ [state]
+-- hsres = case splitTupleType res_ty of
+-- -- Result type must be a two tuple (state, ports)
+-- Just [outstate_ty, outport_ty] -> if Type.coreEqType state_ty outstate_ty
+-- then
+-- Tuple [state, useAsPort (mkHsValueMap outport_ty)]
+-- else
+-- error $ "Input state type of function " ++ hsname ++ ": " ++ (showSDoc $ ppr state_ty) ++ " does not match output state type: " ++ (showSDoc $ ppr outstate_ty)
+-- otherwise -> error $ "Return type of top-level function " ++ hsname ++ " must be a two-tuple containing a state and output ports."
+-- in
+-- (hsargs, hsres)
+-- else
+-- -- Just use everything as a port
+-- (map (useAsPort . mkHsValueMap) arg_tys, useAsPort $ mkHsValueMap res_ty)
-- | Adds signal names to the given FlatFunction
-nameFlatFunction ::
- FlatFunction
- -> FlatFunction
-
-nameFlatFunction flatfunc =
- -- Name the signals
- let
- s = flat_sigs flatfunc
- s' = map nameSignal s in
- flatfunc { flat_sigs = s' }
- where
- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
- nameSignal (id, info) =
- let hints = nameHints info in
- let parts = ("sig" : hints) ++ [show id] in
- let name = concat $ List.intersperse "_" parts in
- (id, info {sigName = Just name})
-
--- | Splits a tuple type into a list of element types, or Nothing if the type
--- is not a tuple type.
-splitTupleType ::
- Type -- ^ The type to split
- -> Maybe [Type] -- ^ The tuples element types
-
-splitTupleType ty =
- case Type.splitTyConApp_maybe ty of
- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
- then
- Just args
- else
- Nothing
- Nothing -> Nothing
+-- nameFlatFunction ::
+-- FlatFunction
+-- -> FlatFunction
+--
+-- nameFlatFunction flatfunc =
+-- -- Name the signals
+-- let
+-- s = flat_sigs flatfunc
+-- s' = map nameSignal s in
+-- flatfunc { flat_sigs = s' }
+-- where
+-- nameSignal :: (SignalId, SignalInfo) -> (SignalId, SignalInfo)
+-- nameSignal (id, info) =
+-- let hints = nameHints info in
+-- let parts = ("sig" : hints) ++ [show id] in
+-- let name = concat $ List.intersperse "_" parts in
+-- (id, info {sigName = Just name})
+--
+-- -- | Splits a tuple type into a list of element types, or Nothing if the type
+-- -- is not a tuple type.
+-- splitTupleType ::
+-- Type -- ^ The type to split
+-- -> Maybe [Type] -- ^ The tuples element types
+--
+-- splitTupleType ty =
+-- case Type.splitTyConApp_maybe ty of
+-- Just (tycon, args) -> if TyCon.isTupleTyCon tycon
+-- then
+-- Just args
+-- else
+-- Nothing
+-- Nothing -> Nothing
-- vim: set ts=8 sw=2 sts=2 expandtab:
projects / matthijs / master-project / cλash.git / commitdiff