From: Christiaan Baaij Date: Sat, 11 Jul 2009 20:23:59 +0000 (+0200) Subject: Great speed-up in type generation X-Git-Url: https://git.stderr.nl/gitweb?a=commitdiff_plain;h=758998d6ef18ab5124c65518781c358d76d229ab;p=matthijs%2Fmaster-project%2Fc%CE%BBash.git Great speed-up in type generation Now just normalize tfp ints that are used as keys for the type map Before these were translated to integers. Save a map caches tfp ints, and their correspding integer literal --- diff --git a/Adders.hs b/Adders.hs index d9c1d26..f0987fd 100644 --- a/Adders.hs +++ b/Adders.hs @@ -178,8 +178,8 @@ highordtest = \x -> xand a b = hwand a b -functiontest :: SizedWord D8 -> SizedWord D8 -functiontest = \a -> let r = a + ((-1) :: SizedWord D8) in r +functiontest :: TFVec D3 (TFVec D4 Bit) -> TFVec D12 Bit +functiontest = \v -> let r = concat v in r xhwnot x = hwnot x diff --git a/CoreTools.hs b/CoreTools.hs index 443586b..eae4122 100644 --- a/CoreTools.hs +++ b/CoreTools.hs @@ -6,6 +6,7 @@ module CoreTools where --Standard modules import qualified Maybe +import System.IO.Unsafe -- GHC API import qualified GHC @@ -14,6 +15,7 @@ import qualified TcType import qualified HsExpr import qualified HsTypes import qualified HsBinds +import qualified HscTypes import qualified RdrName import qualified Name import qualified OccName @@ -41,7 +43,6 @@ eval_tfp_int ty = unsafeRunGhc $ do -- Automatically import modules for any fully qualified identifiers setDynFlag DynFlags.Opt_ImplicitImportQualified - --setDynFlag DynFlags.Opt_D_dump_if_trace let from_int_t_name = mkRdrName "Types.Data.Num" "fromIntegerT" let from_int_t = SrcLoc.noLoc $ HsExpr.HsVar from_int_t_name @@ -60,9 +61,15 @@ eval_tfp_int ty = core <- toCore modules expr execCore core +normalise_tfp_int :: HscTypes.HscEnv -> Type.Type -> Type.Type +normalise_tfp_int env ty = + unsafePerformIO $ do + nty <- normaliseType env ty + return nty + -- | Get the width of a SizedWord type -sized_word_len :: Type.Type -> Int -sized_word_len ty = eval_tfp_int (sized_word_len_ty ty) +-- sized_word_len :: HscTypes.HscEnv -> Type.Type -> Int +-- sized_word_len env ty = eval_tfp_int env (sized_word_len_ty ty) sized_word_len_ty :: Type.Type -> Type.Type sized_word_len_ty ty = len @@ -73,8 +80,8 @@ sized_word_len_ty ty = len [len] = args -- | Get the width of a SizedInt type -sized_int_len :: Type.Type -> Int -sized_int_len ty = eval_tfp_int (sized_int_len_ty ty) +-- sized_int_len :: HscTypes.HscEnv -> Type.Type -> Int +-- sized_int_len env ty = eval_tfp_int env (sized_int_len_ty ty) sized_int_len_ty :: Type.Type -> Type.Type sized_int_len_ty ty = len @@ -85,8 +92,8 @@ sized_int_len_ty ty = len [len] = args -- | Get the upperbound of a RangedWord type -ranged_word_bound :: Type.Type -> Int -ranged_word_bound ty = eval_tfp_int (ranged_word_bound_ty ty) +-- ranged_word_bound :: HscTypes.HscEnv -> Type.Type -> Int +-- ranged_word_bound env ty = eval_tfp_int env (ranged_word_bound_ty ty) ranged_word_bound_ty :: Type.Type -> Type.Type ranged_word_bound_ty ty = len @@ -113,8 +120,8 @@ ranged_word_bound_ty ty = len -- execCore core -- | Get the length of a FSVec type -tfvec_len :: Type.Type -> Int -tfvec_len ty = eval_tfp_int (tfvec_len_ty ty) +-- tfvec_len :: HscTypes.HscEnv -> Type.Type -> Int +-- tfvec_len env ty = eval_tfp_int env (tfvec_len_ty ty) tfvec_len_ty :: Type.Type -> Type.Type tfvec_len_ty ty = len diff --git a/Generate.hs b/Generate.hs index a72cc62..e7a5198 100644 --- a/Generate.hs +++ b/Generate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PackageImports #-} + module Generate where -- Standard modules @@ -5,6 +7,8 @@ import qualified Control.Monad as Monad 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 @@ -35,10 +39,11 @@ import Pretty -- | 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. @@ -74,22 +79,22 @@ genExprRes wrap dst func args = do -- | 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 @@ -100,8 +105,8 @@ genNegation' _ f [arg] = return $ op (varToVHDLExpr arg) -- | 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 @@ -111,8 +116,8 @@ genFCall' switch (Left res) f args = do 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 @@ -125,90 +130,93 @@ genFromSizedWord' (Right name) _ _ = error $ "\nGenerate.genFromSizedWord': Cann 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 @@ -234,22 +242,19 @@ genFold' left (Left res) f [folded_f, start, vec] = do 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") @@ -257,7 +262,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do -- 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 @@ -269,6 +274,7 @@ genFold' left (Left res) f [folded_f, start, vec] = do 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") @@ -291,55 +297,57 @@ genFold' left (Left res) f [folded_f, start, vec] = do 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' @@ -355,51 +363,55 @@ genCopy' (Left res) f args@[arg] = 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 @@ -422,15 +434,11 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do 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 @@ -443,7 +451,7 @@ genIterateOrGenerate' iter (Left res) f [app_f, start] = do -- 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 @@ -474,14 +482,15 @@ genApplication :: -> 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 = @@ -494,7 +503,7 @@ genApplication dst f args = -- 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 @@ -513,13 +522,13 @@ genApplication 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 @@ -942,50 +951,50 @@ genUnconsVectorFuns elemTM vectorTM = -- | 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 ) ) ] diff --git a/HsTools.hs b/HsTools.hs index 0f3e463..22cd57f 100644 --- a/HsTools.hs +++ b/HsTools.hs @@ -3,7 +3,7 @@ module HsTools where -- Standard modules import qualified Unsafe.Coerce - +import qualified Maybe -- GHC API import qualified GHC @@ -31,6 +31,7 @@ import qualified RnEnv import qualified TcExpr import qualified TcEnv import qualified TcSimplify +import qualified TcTyFuns import qualified Desugar import qualified InstEnv import qualified FamInstEnv @@ -123,6 +124,20 @@ mkId rdr_name = do TcEnv.tcLookupId name return id +normaliseType :: + HscTypes.HscEnv + -> Type.Type + -> IO Type.Type +normaliseType env ty = do + (err, nty) <- MonadUtils.liftIO $ + -- Initialize the typechecker monad + TcRnMonad.initTcPrintErrors env PrelNames.iNTERACTIVE $ do + -- Normalize the type + (_, nty) <- TcTyFuns.tcNormaliseFamInst ty + return nty + let normalized_ty = Maybe.fromJust nty + return normalized_ty + -- | Translate a core Type to an HsType. Far from complete so far. coreToHsType :: Type.Type -> HsTypes.LHsType RdrName.RdrName -- Translate TyConApps diff --git a/Normalize.hs b/Normalize.hs index a299fd3..fe544ed 100644 --- a/Normalize.hs +++ b/Normalize.hs @@ -29,11 +29,13 @@ import qualified NameSet import qualified CoreFVs import qualified CoreUtils import qualified MkCore +import qualified HscTypes import Outputable ( showSDoc, ppr, nest ) -- Local imports import NormalizeTypes import NormalizeTools +import VHDLTypes import CoreTools import Pretty @@ -453,14 +455,15 @@ funextracttop = everywhere ("funextract", funextract) transforms = [argproptop, funextracttop, etatop, betatop, castproptop, letremovetop, letrectop, letsimpltop, letflattop, casewildtop, scrutsimpltop, casevalsimpltop, caseremovetop, inlinenonreptop, appsimpltop] -- Turns the given bind into VHDL -normalizeModule :: - UniqSupply.UniqSupply -- ^ A UniqSupply we can use +normalizeModule :: + HscTypes.HscEnv + -> UniqSupply.UniqSupply -- ^ A UniqSupply we can use -> [(CoreBndr, CoreExpr)] -- ^ All bindings we know (i.e., in the current module) -> [CoreBndr] -- ^ The bindings to generate VHDL for (i.e., the top level bindings) -> [Bool] -- ^ For each of the bindings to generate VHDL for, if it is stateful - -> [(CoreBndr, CoreExpr)] -- ^ The resulting VHDL + -> ([(CoreBndr, CoreExpr)], TypeState) -- ^ The resulting VHDL -normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession uniqsupply $ do +normalizeModule env uniqsupply bindings generate_for statefuls = runTransformSession env uniqsupply $ do -- Put all the bindings in this module in the tsBindings map putA tsBindings (Map.fromList bindings) -- (Recursively) normalize each of the requested bindings @@ -469,8 +472,9 @@ normalizeModule uniqsupply bindings generate_for statefuls = runTransformSession bindings_map <- getA tsBindings let bindings = Map.assocs bindings_map normalized_bindings <- getA tsNormalized + typestate <- getA tsType -- But return only the normalized bindings - return $ filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings + return $ (filter ((flip VarSet.elemVarSet normalized_bindings) . fst) bindings, typestate) normalizeBind :: CoreBndr -> TransformSession () normalizeBind bndr = diff --git a/NormalizeTools.hs b/NormalizeTools.hs index 85fae47..0508b38 100644 --- a/NormalizeTools.hs +++ b/NormalizeTools.hs @@ -30,11 +30,13 @@ import qualified IdInfo import qualified CoreUtils import qualified CoreSubst import qualified VarSet +import qualified HscTypes import Outputable ( showSDoc, ppr, nest ) -- Local imports import NormalizeTypes import Pretty +import VHDLTypes import qualified VHDLTools -- Create a new internal var with the given name and type. A Unique is @@ -246,8 +248,11 @@ substitute ((b, e):subss) expr = substitute subss' expr' -- Run a given TransformSession. Used mostly to setup the right calls and -- an initial state. -runTransformSession :: UniqSupply.UniqSupply -> TransformSession a -> a -runTransformSession uniqSupply session = State.evalState session (emptyTransformState uniqSupply) +runTransformSession :: HscTypes.HscEnv -> UniqSupply.UniqSupply -> TransformSession a -> a +runTransformSession env uniqSupply session = State.evalState session emptyTransformState + where + emptyTypeState = TypeState Map.empty [] Map.empty Map.empty env + emptyTransformState = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState -- Is the given expression representable at runtime, based on the type? isRepr :: CoreSyn.CoreExpr -> TransformMonad Bool diff --git a/NormalizeTypes.hs b/NormalizeTypes.hs index 89ed53d..56cba91 100644 --- a/NormalizeTypes.hs +++ b/NormalizeTypes.hs @@ -28,8 +28,6 @@ data TransformState = TransformState { , tsNormalized_ :: VarSet.VarSet -- ^ The binders that have been normalized , tsType_ :: TypeState } --- Create an (almost) empty TransformState, containing just a UniqSupply. -emptyTransformState uniqSupply = TransformState uniqSupply Map.empty VarSet.emptyVarSet emptyTypeState $( Data.Accessor.Template.deriveAccessors ''TransformState ) diff --git a/Translator.hs b/Translator.hs index 85f790a..feb712b 100644 --- a/Translator.hs +++ b/Translator.hs @@ -48,17 +48,17 @@ import TranslatorTypes 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 @@ -67,7 +67,7 @@ makeVHDL filename name stateful = do listBindings :: String -> IO [()] listBindings filename = do - core <- loadModule filename + (core, env) <- loadModule filename let binds = CoreSyn.flattenBinds $ cm_binds core mapM (listBinding) binds @@ -86,7 +86,7 @@ listBinding (b, e) = do -- | 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 @@ -99,8 +99,8 @@ listBind filename name = do -- | 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 @@ -111,8 +111,8 @@ moduleToVHDL core list = do 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 @@ -143,7 +143,7 @@ writeVHDL dir (name, vhdl) = do 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 @@ -156,7 +156,8 @@ loadModule filename = --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)] @@ -173,200 +174,200 @@ findBind binds lookfor = -- | 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: diff --git a/VHDL.hs b/VHDL.hs index daf843f..6039447 100644 --- a/VHDL.hs +++ b/VHDL.hs @@ -40,15 +40,16 @@ import Constants import Generate createDesignFiles :: - [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] + TypeState + -> [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)] -> [(AST.VHDLId, AST.DesignFile)] -createDesignFiles binds = +createDesignFiles init_typestate binds = (mkVHDLBasicId "types", AST.DesignFile ieee_context [type_package_dec, type_package_body]) : map (Arrow.second $ AST.DesignFile full_context) units where - init_session = VHDLState emptyTypeState Map.empty + init_session = VHDLState init_typestate Map.empty (units, final_session) = State.runState (createLibraryUnits binds) init_session tyfun_decls = map snd $ Map.elems (final_session ^. vsType ^. vsTypeFuns) @@ -257,7 +258,9 @@ mkConcSm (bndr, Cast expr ty) = mkConcSm (bndr, expr) -- assignment. This should only happen for dataconstructors without arguments. -- TODO: Integrate this with the below code for application (essentially this -- is an application without arguments) -mkConcSm (bndr, Var v) = return $ [mkUncondAssign (Left bndr) (varToVHDLExpr v)] +mkConcSm (bndr, Var v) = do + ty_state <- getA vsType + return $ [mkUncondAssign (Left bndr) ((varToVHDLExpr ty_state) v)] mkConcSm (bndr, app@(CoreSyn.App _ _))= do let (CoreSyn.Var f, args) = CoreSyn.collectArgs app @@ -285,13 +288,14 @@ mkConcSm (bndr, expr@(Case (Var scrut) b ty [alt])) = -- binders in the alts and only variables in the case values and a variable -- for a scrutinee. We check the constructor of the second alt, since the -- first is the default case, if there is any. -mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = - let - cond_expr = (varToVHDLExpr scrut) AST.:=: (altconToVHDLExpr con) - true_expr = (varToVHDLExpr true) - false_expr = (varToVHDLExpr false) - in - return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] +mkConcSm (bndr, (Case (Var scrut) b ty [(_, _, Var false), (con, _, Var true)])) = do { + ; ty_state <- getA vsType + ; let { cond_expr = (varToVHDLExpr ty_state scrut) AST.:=: (altconToVHDLExpr con) + ; true_expr = (varToVHDLExpr ty_state true) + ; false_expr = (varToVHDLExpr ty_state false) + } ; + ; return [mkCondAssign (Left bndr) cond_expr true_expr false_expr] + } mkConcSm (_, (Case (Var _) _ _ alts)) = error "\nVHDL.mkConcSm: Not in normal form: Case statement with more than two alternatives" mkConcSm (_, Case _ _ _ _) = error "\nVHDL.mkConcSm: Not in normal form: Case statement has does not have a simple variable as scrutinee" mkConcSm (bndr, expr) = error $ "\nVHDL.mkConcSM: Unsupported binding in let expression: " ++ pprString bndr ++ " = " ++ pprString expr diff --git a/VHDLTools.hs b/VHDLTools.hs index cf91cc7..1e6e5bc 100644 --- a/VHDLTools.hs +++ b/VHDLTools.hs @@ -7,6 +7,7 @@ import qualified Data.List as List import qualified Data.Map as Map import qualified Control.Monad as Monad import qualified Control.Arrow as Arrow +import qualified Control.Monad.Trans.State as State import qualified Data.Monoid as Monoid import Data.Accessor import Debug.Trace @@ -122,8 +123,8 @@ mkComponentInst label entity_id portassigns = AST.CSISm compins ----------------------------------------------------------------------------- -- Turn a variable reference into a AST expression -varToVHDLExpr :: Var.Var -> AST.Expr -varToVHDLExpr var = +varToVHDLExpr :: TypeState -> Var.Var -> AST.Expr +varToVHDLExpr ty_state var = case Id.isDataConWorkId_maybe var of Just dc -> dataconToVHDLExpr dc -- This is a dataconstructor. @@ -133,13 +134,13 @@ varToVHDLExpr var = -- should still be translated to integer literals. It is probebly not the -- best solution to translate them here. -- FIXME: Find a better solution for translating instances of tfp integers - Nothing -> + Nothing -> let ty = Var.varType var res = case Type.splitTyConApp_maybe ty of Just (tycon, args) -> case Name.getOccString (TyCon.tyConName tycon) of - "Dec" -> AST.PrimLit $ (show (eval_tfp_int ty)) + "Dec" -> AST.PrimLit $ (show (fst ( State.runState (tfp_to_int ty) ty_state ) ) ) otherwise -> AST.PrimName $ AST.NSimple $ varToVHDLId var in res @@ -152,7 +153,7 @@ vhdlNameToVHDLExpr = AST.PrimName idToVHDLExpr = vhdlNameToVHDLExpr . AST.NSimple -- Turn a Core expression into an AST expression -exprToVHDLExpr = varToVHDLExpr . exprToVar +exprToVHDLExpr ty_state = (varToVHDLExpr ty_state) . exprToVar -- Turn a alternative constructor into an AST expression. For -- dataconstructors, this is only the constructor itself, not any arguments it @@ -318,7 +319,9 @@ construct_vhdl_ty ty = do "TFVec" -> mk_vector_ty ty "SizedWord" -> mk_unsigned_ty ty "SizedInt" -> mk_signed_ty ty - "RangedWord" -> mk_natural_ty 0 (ranged_word_bound ty) + "RangedWord" -> do + bound <- tfp_to_int (ranged_word_bound_ty ty) + mk_natural_ty 0 bound -- Create a custom type from this tycon otherwise -> mk_tycon_ty tycon args Nothing -> return (Left $ "VHDLTools.construct_vhdl_ty: Cannot create type for non-tycon type: " ++ pprString ty ++ "\n") @@ -370,10 +373,11 @@ mk_vector_ty :: mk_vector_ty ty = do types_map <- getA vsTypes + env <- getA vsHscEnv let (nvec_l, nvec_el) = Type.splitAppTy ty let (nvec, leng) = Type.splitAppTy nvec_l let vec_ty = Type.mkAppTy nvec nvec_el - let len = tfvec_len ty + len <- tfp_to_int (tfvec_len_ty ty) let el_ty = tfvec_elem ty el_ty_tm_either <- vhdl_ty_either el_ty case el_ty_tm_either of @@ -413,7 +417,7 @@ mk_unsigned_ty :: Type.Type -- ^ Haskell type of the unsigned integer -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) mk_unsigned_ty ty = do - let size = sized_word_len ty + size <- tfp_to_int (sized_word_len_ty ty) let ty_id = mkVHDLExtId $ "unsigned_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn unsignedTM (Just range) @@ -423,7 +427,7 @@ mk_signed_ty :: Type.Type -- ^ Haskell type of the signed integer -> TypeSession (Either String (AST.TypeMark, Either AST.TypeDef AST.SubtypeIn)) mk_signed_ty ty = do - let size = sized_word_len ty + size <- tfp_to_int (sized_int_len_ty ty) let ty_id = mkVHDLExtId $ "signed_" ++ show (size - 1) let range = AST.ConstraintIndex $ AST.IndexConstraint [AST.ToRange (AST.PrimLit "0") (AST.PrimLit $ show (size - 1))] let ty_def = AST.SubtypeIn signedTM (Just range) @@ -469,8 +473,9 @@ mkHType ty = do case elem_htype_either of -- Could create element type Right elem_htype -> do - len <- tfp_to_int (tfvec_len_ty ty) - return $ Right $ VecType len elem_htype + env <- getA vsHscEnv + let norm_ty = normalise_tfp_int env (tfvec_len_ty ty) + return $ Right $ VecType (OrdType norm_ty) elem_htype -- Could not create element type Left err -> return $ Left $ "VHDLTools.mkHType: Can not construct vectortype for elementtype: " ++ pprString el_ty ++ "\n" diff --git a/VHDLTypes.hs b/VHDLTypes.hs index b9db66a..b4c1d69 100644 --- a/VHDLTypes.hs +++ b/VHDLTypes.hs @@ -13,6 +13,7 @@ import qualified Data.Accessor.Template -- GHC API imports import qualified Type import qualified CoreSyn +import qualified HscTypes -- ForSyDe imports import qualified ForSyDe.Backend.VHDL.AST as AST @@ -40,7 +41,7 @@ instance Ord OrdType where data HType = StdType OrdType | ADTType String [HType] | - VecType Int HType | + VecType OrdType HType | SizedWType Int | RangedWType Int | SizedIType Int | @@ -66,12 +67,11 @@ data TypeState = TypeState { vsTypeDecls_ :: [AST.PackageDecItem], -- | A map of vector Core type -> VHDL type function vsTypeFuns_ :: TypeFunMap, - vsTfpInts_ :: TfpIntMap + vsTfpInts_ :: TfpIntMap, + vsHscEnv_ :: HscTypes.HscEnv } -- Derive accessors $( Data.Accessor.Template.deriveAccessors ''TypeState ) --- Define an empty TypeState -emptyTypeState = TypeState Map.empty [] Map.empty Map.empty -- Define a session type TypeSession = State.State TypeState