From: sewardj Date: Tue, 17 Oct 2000 11:34:46 +0000 (+0000) Subject: [project @ 2000-10-17 11:34:46 by sewardj] X-Git-Tag: Approximately_9120_patches~3552 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=087fdd53c7d6bb6cb17574133abc2de4f1816c7e;p=ghc-hetmet.git [project @ 2000-10-17 11:34:46 by sewardj] Changes needed to get TcExpr to compile. --- diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index d07de86..df54d8f 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -12,9 +12,10 @@ module CoreLint ( #include "HsVersions.h" -import IO ( hPutStr, hPutStrLn, stdout ) +import IO ( hPutStr, hPutStrLn, stdout ) -import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting, opt_PprStyle_Debug ) +import CmdLineOpts ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting, + opt_PprStyle_Debug ) import CoreSyn import Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars, mustHaveLocalBinding ) @@ -28,10 +29,10 @@ import VarSet import Subst ( mkTyVarSubst, substTy ) import Name ( getSrcLoc ) import PprCore -import ErrUtils ( doIfSet, dumpIfSet, ghcExit, Message, +import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, ErrMsg, addErrLocHdrLine, pprBagOfErrors, WarnMsg, pprBagOfWarnings) -import SrcLoc ( SrcLoc, noSrcLoc, isNoSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( Type, tyVarsOfType, splitFunTy_maybe, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, @@ -58,29 +59,29 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -beginPass :: String -> IO () -beginPass pass_name - | opt_D_show_passes +beginPass :: DynFlags -> String -> IO () +beginPass dflags pass_name + | dopt_D_show_passes dflags = hPutStrLn stdout ("*** " ++ pass_name) | otherwise = return () -endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind] -endPass pass_name dump_flag binds +endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind] +endPass dflags pass_name dump_flag binds = do - (binds, _) <- endPassWithRules pass_name dump_flag binds Nothing + (binds, _) <- endPassWithRules dflags pass_name dump_flag binds Nothing return binds -endPassWithRules :: String -> Bool -> [CoreBind] -> Maybe RuleBase +endPassWithRules :: DynFlags -> String -> Bool -> [CoreBind] -> Maybe RuleBase -> IO ([CoreBind], Maybe RuleBase) -endPassWithRules pass_name dump_flag binds rules +endPassWithRules dflags pass_name dump_flag binds rules = do -- ToDo: force the rules? -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated - if opt_D_show_passes then + if dopt_D_show_passes dflags then hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds)) else return () @@ -92,7 +93,7 @@ endPassWithRules pass_name dump_flag binds rules Just rb -> pprRuleBase rb) -- Type check - lintCoreBindings pass_name binds + lintCoreBindings dflags pass_name binds -- ToDo: lint the rules return (binds, rules) @@ -130,13 +131,13 @@ Outstanding issues: -- may well be happening...); \begin{code} -lintCoreBindings :: String -> [CoreBind] -> IO () +lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () -lintCoreBindings whoDunnit binds - | not opt_DoCoreLinting +lintCoreBindings dflags whoDunnit binds + | not (dopt_DoCoreLinting dflags) = return () -lintCoreBindings whoDunnit binds +lintCoreBindings dflags whoDunnit binds = case (initL (lint_binds binds)) of (Nothing, Nothing) -> done_lint @@ -156,7 +157,7 @@ lintCoreBindings whoDunnit binds returnL () lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) - done_lint = doIfSet opt_D_show_passes + done_lint = doIfSet_dyn dflags dopt_D_show_passes (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n")) warn warnings = vcat [ @@ -190,19 +191,20 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: SrcLoc +lintUnfolding :: DynFlags + -> SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK -lintUnfolding locn vars expr - | not opt_DoCoreLinting +lintUnfolding dflags locn vars expr + | not (dopt_DoCoreLinting dflags) = (Nothing, Nothing) | otherwise = initL (addLoc (ImportedUnfolding locn) $ - addInScopeVars vars $ - lintCoreExpr expr) + addInScopeVars vars $ + lintCoreExpr expr) \end{code} %************************************************************************ diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index f9c7ae5..79e43ac 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -11,7 +11,7 @@ module ErrUtils ( dontAddErrLoc, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, ghcExit, - doIfSet, dumpIfSet, dumpIfSet_dyn + doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn ) where #include "HsVersions.h" @@ -96,6 +96,10 @@ ghcExit val doIfSet :: Bool -> IO () -> IO () doIfSet flag action | flag = action | otherwise = return () + +doIfSet_dyn :: DynFlags -> (DynFlags -> Bool) -> IO () -> IO() +doIfSet_dyn dflags flag action | flag dflags = action + | otherwise = return () \end{code} \begin{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 86f6437..7a0c4bf 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -10,7 +10,8 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn import CoreUnfold ( Unfolding, certainlyWillInline ) -import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_worker_wrapper ) +import CmdLineOpts ( DynFlags, + dopt_D_verbose_core2core, dopt_D_dump_worker_wrapper ) import CoreLint ( beginPass, endPass ) import CoreUtils ( exprType, exprEtaExpandArity ) import MkId ( mkWorkerId ) @@ -56,20 +57,23 @@ info for exported values). \begin{code} -wwTopBinds :: UniqSupply - -> [CoreBind] - -> IO [CoreBind] +wwTopBinds :: DynFlags + -> UniqSupply + -> [CoreBind] + -> IO [CoreBind] -wwTopBinds us binds +wwTopBinds dflags us binds = do { - beginPass "Worker Wrapper binds"; + beginPass dflags "Worker Wrapper binds"; -- Create worker/wrappers, and mark binders with their -- "strictness info" [which encodes their worker/wrapper-ness] let { binds' = workersAndWrappers us binds }; - endPass "Worker Wrapper binds" (opt_D_dump_worker_wrapper || - opt_D_verbose_core2core) binds' + endPass dflags "Worker Wrapper binds" + (dopt_D_dump_worker_wrapper dflags || + dopt_D_verbose_core2core dflags) + binds' } \end{code} diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index d44bebc..b9b74c3 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -18,8 +18,9 @@ import TcSimplify ( tcSimplifyCheckThetas ) import TysWiredIn ( integerTy, doubleTy ) import Type ( Type ) -import PrelNames ( numClassKey ) +import PrelNames ( numClassName ) import Outputable +import HscTypes ( TyThing(..) ) \end{code} \begin{code} @@ -38,9 +39,9 @@ tc_defaults [DefaultDecl [] locn] tc_defaults [DefaultDecl mono_tys locn] = tcLookupGlobal_maybe numClassName `thenNF_Tc` \ maybe_num -> - case maybe_num of { + case maybe_num of Just (AClass num_class) -> common_case num_class - other -> returnTc [] ; + other -> returnTc [] -- In the Nothing case, Num has not been sucked in, so the -- defaults will never be used; so simply discard the default decl. -- This slightly benefits modules that don't use any @@ -59,7 +60,7 @@ tc_defaults [DefaultDecl mono_tys locn] [ (num_class, [ty]) | ty <- tau_tys ] `thenTc_` returnTc tau_tys - } + tc_defaults decls@(DefaultDecl _ loc : _) = tcAddSrcLoc loc $ diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5875c2f..94e70d6 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -28,7 +28,10 @@ module TcEnv( -- New Ids newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName + newDefaultMethodName, newDFunName, + + -- ??? + tcSetEnv, explicitLookupId ) where #include "HsVersions.h" diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index cb7f9e0..90d106e 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -25,7 +25,7 @@ import Inst ( InstOrigin(..), getIPsOfLIE, instToId, ipToId ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcInstId, +import TcEnv ( TcTyThing(..), tcInstId, tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, tcLookupTyCon, tcLookupDataCon, tcLookup, tcExtendGlobalTyVars @@ -61,16 +61,18 @@ import UsageSPUtils ( unannotTy ) import VarSet ( elemVarSet, mkVarSet ) import TysWiredIn ( boolTy ) import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) -import PrelNames ( cCallableClassKey, cReturnableClassKey, - enumFromClassOpKey, enumFromThenClassOpKey, - enumFromToClassOpKey, enumFromThenToClassOpKey, - thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey +import PrelNames ( cCallableClassName, + cReturnableClassName, + enumFromName, enumFromThenName, + enumFromToName, enumFromThenToName, + thenMName, failMName, returnMName, ioTyConName ) import Outputable import Maybes ( maybeToBool, mapMaybe ) import ListSetOps ( minusList ) import Util import CmdLineOpts ( opt_WarnMissingFields ) +import HscTypes ( TyThing(..) ) \end{code} @@ -396,7 +398,7 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty -- Check that the record bindings match the constructor -- con_name is syntactically constrained to be a data constructor - tcLookupDataCon con_name `thenTc` \ (data_con, _, _) -> + tcLookupDataCon con_name `thenTc` \ data_con -> let bad_fields = badFields rbinds data_con in @@ -472,7 +474,7 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty -- STEP 1 -- Figure out the tycon and data cons from the first field name let - (Just sel_id : _) = maybe_sel_ids + (Just (AnId sel_id) : _) = maybe_sel_ids (_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) ) splitSigmaTy (idType sel_id) -- Selectors can be overloaded -- when the data type has a context @@ -553,7 +555,7 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty = unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) -> - tcLookupGlobalId enumFromClassOpName `thenNF_Tc` \ sel_id -> + tcLookupGlobalId enumFromName `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) -> @@ -565,7 +567,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupGlobalId enumFromThenClassOpName `thenNF_Tc` \ sel_id -> + tcLookupGlobalId enumFromThenName `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) -> returnTc (ArithSeqOut (HsVar enum_from_then_id) @@ -577,7 +579,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupGlobalId enumFromToClassOpName `thenNF_Tc` \ sel_id -> + tcLookupGlobalId enumFromToName `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) -> returnTc (ArithSeqOut (HsVar enum_from_to_id) @@ -590,7 +592,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> - tcLookupGlobalId enumFromThenToClassOpName `thenNF_Tc` \ sel_id -> + tcLookupGlobalId enumFromThenToName `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) -> returnTc (ArithSeqOut (HsVar eft_id) @@ -866,9 +868,9 @@ tcDoStmts do_or_lc stmts src_loc res_ty -- then = then -- where the second "then" sees that it already exists in the "available" stuff. -- - tcLookupGlobalId returnMClassOpName `thenNF_Tc` \ return_sel_id -> - tcLookupGlobalId thenMClassOpName `thenNF_Tc` \ then_sel_id -> - tcLookupGlobalId failMClassOpName `thenNF_Tc` \ fail_sel_id -> + tcLookupGlobalId returnMName `thenNF_Tc` \ return_sel_id -> + tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id -> + tcLookupGlobalId failMName `thenNF_Tc` \ fail_sel_id -> newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) -> newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) -> newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) -> diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index afdf82f..f1a747f 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -17,7 +17,7 @@ import TcMonoType ( tcHsType ) import TcEnv ( TcEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetEnv, - tcLookupGlobal_maybe, explicitLookupId, valueEnvIds + tcLookupGlobal_maybe, explicitLookupId, tcEnvIds ) import RnHsSyn ( RenamedHsDecl ) @@ -29,9 +29,7 @@ import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import Id ( Id, mkId, mkVanillaId, - isDataConWrapId_maybe - ) +import Id ( Id, mkId, mkVanillaId, isDataConWrapId_maybe ) import MkId ( mkCCallOpId ) import IdInfo import DataCon ( dataConSig, dataConArgTys ) @@ -42,6 +40,7 @@ import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable import Util ( zipWithEqual ) +import HscTypes ( TyThing(..) ) \end{code} Ultimately, type signatures in interfaces will have pragmatic @@ -61,7 +60,7 @@ tcInterfaceSigs unf_env decls = listTc [ do_one name ty id_infos src_loc | SigD (IfaceSig name ty id_infos src_loc) <- decls] where - in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env) + in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env) do_one name ty id_infos src_loc = tcAddSrcLoc src_loc $ @@ -137,7 +136,8 @@ tcPragExpr unf_env name in_scope_vars expr -- Check for type consistency in the unfolding tcGetSrcLoc `thenNF_Tc` \ src_loc -> - case lintUnfolding src_loc in_scope_vars core_expr' of + getDOptsTc `thenTc` \ dflags -> + case lintUnfolding dflags src_loc in_scope_vars core_expr' of (Nothing,_) -> returnTc core_expr' -- ignore warnings (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg) where