From: simonmar Date: Tue, 17 Oct 2000 13:22:12 +0000 (+0000) Subject: [project @ 2000-10-17 13:22:10 by simonmar] X-Git-Tag: Approximately_9120_patches~3547 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=dbb27b50948726c09fae681bca921ba3c00d859b;p=ghc-hetmet.git [project @ 2000-10-17 13:22:10 by simonmar] Flags hacking: - `dopt_GlasgowExts' is now written `dopt Opt_GlasgowExts' - convert all the warning options into DynFlags --- diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index df54d8f..6f7ad36 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -14,8 +14,6 @@ module CoreLint ( import IO ( hPutStr, hPutStrLn, stdout ) -import CmdLineOpts ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting, - opt_PprStyle_Debug ) import CoreSyn import Rules ( RuleBase, pprRuleBase ) import CoreFVs ( idFreeVars, mustHaveLocalBinding ) @@ -42,6 +40,7 @@ import Type ( Type, tyVarsOfType, ) import TyCon ( TyCon, isPrimTyCon, tyConDataCons ) import BasicTypes ( RecFlag(..), isNonRec ) +import CmdLineOpts import Maybe import Outputable @@ -61,7 +60,7 @@ and do Core Lint when necessary. \begin{code} beginPass :: DynFlags -> String -> IO () beginPass dflags pass_name - | dopt_D_show_passes dflags + | dopt Opt_D_show_passes dflags = hPutStrLn stdout ("*** " ++ pass_name) | otherwise = return () @@ -81,7 +80,7 @@ endPassWithRules dflags pass_name dump_flag binds rules -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated - if dopt_D_show_passes dflags then + if dopt Opt_D_show_passes dflags then hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds)) else return () @@ -134,7 +133,7 @@ Outstanding issues: lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO () lintCoreBindings dflags whoDunnit binds - | not (dopt_DoCoreLinting dflags) + | not (dopt Opt_DoCoreLinting dflags) = return () lintCoreBindings dflags whoDunnit binds @@ -157,7 +156,7 @@ lintCoreBindings dflags whoDunnit binds returnL () lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs) - done_lint = doIfSet_dyn dflags dopt_D_show_passes + done_lint = doIfSet_dyn dflags (dopt Opt_D_show_passes) (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n")) warn warnings = vcat [ @@ -198,7 +197,7 @@ lintUnfolding :: DynFlags -> (Maybe Message, Maybe Message) -- (Nothing,_) => OK lintUnfolding dflags locn vars expr - | not (dopt_DoCoreLinting dflags) + | not (dopt Opt_DoCoreLinting dflags) = (Nothing, Nothing) | otherwise diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 69f7150..4ed1cb4 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -36,7 +36,7 @@ import CmdLineOpts ( opt_UF_CreationThreshold, opt_UF_FunAppDiscount, opt_UF_KeenessFactor, opt_UF_DearOp, opt_UnfoldCasms, - DynFlags, dopt_D_dump_inlinings + DynFlags, DynFlag(..), dopt ) import CoreSyn import PprCore ( pprCoreExpr ) @@ -613,7 +613,7 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont in #ifdef DEBUG - if dopt_D_dump_inlinings dflags then + if dopt Opt_D_dump_inlinings dflags then pprTrace "Considering inlining" (ppr id <+> vcat [text "black listed:" <+> ppr black_listed, text "occ info:" <+> ppr occ, diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d0e8859..aa7498d 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -18,68 +18,16 @@ module CmdLineOpts ( switchIsOn, isStaticHscFlag, - -- debugging opts - dopt_D_dump_absC, - dopt_D_dump_asm, - dopt_D_dump_cpranal, - dopt_D_dump_cse, - dopt_D_dump_deriv, - dopt_D_dump_ds, - dopt_D_dump_flatC, - dopt_D_dump_foreign, - dopt_D_dump_hi_diffs, - dopt_D_dump_inlinings, - dopt_D_dump_occur_anal, - dopt_D_dump_parsed, - dopt_D_dump_realC, - dopt_D_dump_rn, - dopt_D_dump_rules, - dopt_D_dump_simpl, - dopt_D_dump_simpl_iterations, - dopt_D_dump_simpl_stats, - dopt_D_dump_spec, - dopt_D_dump_stg, - dopt_D_dump_stranal, - dopt_D_dump_tc, - dopt_D_dump_types, - dopt_D_dump_usagesp, - dopt_D_dump_worker_wrapper, - dopt_D_show_passes, - dopt_D_dump_rn_trace, - dopt_D_dump_rn_stats, - dopt_D_dump_stix, - dopt_D_dump_minimal_imports, - dopt_D_source_stats, - dopt_D_verbose_core2core, - dopt_D_verbose_stg2stg, - dopt_DoCoreLinting, - dopt_DoStgLinting, - dopt_DoUSPLinting, - opt_PprStyle_NoPrags, opt_PprUserLength, opt_PprStyle_Debug, + dopt, + -- other dynamic flags dopt_CoreToDo, dopt_StgToDo, - -- warning opts - opt_WarnDuplicateExports, - opt_WarnHiShadows, - opt_WarnIncompletePatterns, - opt_WarnMissingFields, - opt_WarnMissingMethods, - opt_WarnMissingSigs, - opt_WarnNameShadowing, - opt_WarnOverlappingPatterns, - opt_WarnSimplePatterns, - opt_WarnTypeDefaults, - opt_WarnUnusedBinds, - opt_WarnUnusedImports, - opt_WarnUnusedMatches, - opt_WarnDeprecations, - -- profiling opts opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, @@ -92,9 +40,6 @@ module CmdLineOpts ( opt_AllStrict, opt_DictsStrict, opt_MaxContextReductionDepth, - dopt_AllowOverlappingInstances, - dopt_AllowUndecidableInstances, - dopt_GlasgowExts, opt_Generics, opt_IrrefutableTuples, opt_NumbersStrict, @@ -237,7 +182,7 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoUSPInf - | CoreDoCPResult + | CoreDoCPResult | CoreDoGlomBinds | CoreCSE @@ -312,6 +257,21 @@ data DynFlag | Opt_DoStgLinting | Opt_DoUSPLinting + | Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnIncompletePatterns + | Opt_WarnMissingFields + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnSimplePatterns + | Opt_WarnTypeDefaults + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnDeprecations + -- language opts | Opt_AllowOverlappingInstances | Opt_AllowUndecidableInstances @@ -325,51 +285,8 @@ data DynFlags = DynFlags { flags :: [DynFlag] } -boolOpt :: DynFlag -> DynFlags -> Bool -boolOpt f dflags = f `elem` (flags dflags) - -dopt_D_dump_all = boolOpt Opt_D_dump_all -dopt_D_dump_most = boolOpt Opt_D_dump_most -dopt_D_dump_absC = boolOpt Opt_D_dump_absC -dopt_D_dump_asm = boolOpt Opt_D_dump_asm -dopt_D_dump_cpranal = boolOpt Opt_D_dump_cpranal -dopt_D_dump_deriv = boolOpt Opt_D_dump_deriv -dopt_D_dump_ds = boolOpt Opt_D_dump_ds -dopt_D_dump_flatC = boolOpt Opt_D_dump_flatC -dopt_D_dump_foreign = boolOpt Opt_D_dump_foreign -dopt_D_dump_inlinings = boolOpt Opt_D_dump_inlinings -dopt_D_dump_occur_anal = boolOpt Opt_D_dump_occur_anal -dopt_D_dump_parsed = boolOpt Opt_D_dump_parsed -dopt_D_dump_realC = boolOpt Opt_D_dump_realC -dopt_D_dump_rn = boolOpt Opt_D_dump_rn -dopt_D_dump_simpl = boolOpt Opt_D_dump_simpl -dopt_D_dump_simpl_iterations = boolOpt Opt_D_dump_simpl_iterations -dopt_D_dump_spec = boolOpt Opt_D_dump_spec -dopt_D_dump_stg = boolOpt Opt_D_dump_stg -dopt_D_dump_stranal = boolOpt Opt_D_dump_stranal -dopt_D_dump_tc = boolOpt Opt_D_dump_tc -dopt_D_dump_types = boolOpt Opt_D_dump_types -dopt_D_dump_rules = boolOpt Opt_D_dump_rules -dopt_D_dump_usagesp = boolOpt Opt_D_dump_usagesp -dopt_D_dump_cse = boolOpt Opt_D_dump_cse -dopt_D_dump_worker_wrapper = boolOpt Opt_D_dump_worker_wrapper -dopt_D_show_passes = boolOpt Opt_D_show_passes -dopt_D_dump_rn_trace = boolOpt Opt_D_dump_rn_trace -dopt_D_dump_rn_stats = boolOpt Opt_D_dump_rn_stats -dopt_D_dump_stix = boolOpt Opt_D_dump_stix -dopt_D_dump_simpl_stats = boolOpt Opt_D_dump_simpl_stats -dopt_D_source_stats = boolOpt Opt_D_source_stats -dopt_D_verbose_core2core = boolOpt Opt_D_verbose_core2core -dopt_D_verbose_stg2stg = boolOpt Opt_D_verbose_stg2stg -dopt_D_dump_hi_diffs = boolOpt Opt_D_dump_hi_diffs -dopt_D_dump_minimal_imports = boolOpt Opt_D_dump_minimal_imports -dopt_DoCoreLinting = boolOpt Opt_DoCoreLinting -dopt_DoStgLinting = boolOpt Opt_DoStgLinting -dopt_DoUSPLinting = boolOpt Opt_DoUSPLinting - -dopt_AllowOverlappingInstances = boolOpt Opt_AllowOverlappingInstances -dopt_AllowUndecidableInstances = boolOpt Opt_AllowUndecidableInstances -dopt_GlasgowExts = boolOpt Opt_GlasgowExts +dopt :: DynFlag -> DynFlags -> Bool +dopt f dflags = f `elem` (flags dflags) dopt_CoreToDo :: DynFlags -> CoreToDo dopt_CoreToDo = coreToDo @@ -381,6 +298,7 @@ data HscLang = HscC | HscAsm | HscJava + | HscInterpreter deriving Eq dopt_HscLang :: DynFlags -> HscLang @@ -451,22 +369,6 @@ opt_PprStyle_NoPrags = lookUp SLIT("-dppr-noprags") opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name --- warning opts -opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports") -opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing") -opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns") -opt_WarnMissingFields = lookUp SLIT("-fwarn-missing-fields") -opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods") -opt_WarnMissingSigs = lookUp SLIT("-fwarn-missing-signatures") -opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") -opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns") -opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns") -opt_WarnTypeDefaults = lookUp SLIT("-fwarn-type-defaults") -opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds") -opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports") -opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches") -opt_WarnDeprecations = lookUp SLIT("-fwarn-deprecations") - -- profiling opts opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs") opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs") @@ -495,7 +397,7 @@ opt_UsageSPOn = lookUp SLIT("-fusagesp-on") opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields") {- - The optional '-inpackage=P' flag tells what package + The optional '-inpackage=P' flag tells what package we are compiling this module for. The Prelude, for example is compiled with '-package prelude' -} @@ -561,22 +463,8 @@ opt_UseLongRegs | opt_Unregisterised = 0 %************************************************************************ \begin{code} -isStaticHscFlag f = +isStaticHscFlag f = f `elem` [ - "-fwarn-duplicate-exports", - "-fwarn-hi-shadowing", - "-fwarn-incomplete-patterns", - "-fwarn-missing-fields", - "-fwarn-missing-methods", - "-fwarn-missing-signatures", - "-fwarn-name-shadowing", - "-fwarn-overlapping-patterns", - "-fwarn-simple-patterns", - "-fwarn-type-defaults", - "-fwarn-unused-binds", - "-fwarn-unused-imports", - "-fwarn-unused-matches", - "-fwarn-deprecations", "-fauto-sccs-on-all-toplevs", "-fauto-sccs-on-exported-toplevs", "-fauto-sccs-on-individual-cafs", @@ -701,7 +589,7 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier* #endif } where - mk_assoc_elem k@(MaxSimplifierIterations lvl) + mk_assoc_elem k@(MaxSimplifierIterations lvl) = (iBox (tagOf_SimplSwitch k), SwInt lvl) mk_assoc_elem k@(SimplInlinePhase n) = (iBox (tagOf_SimplSwitch k), SwInt n) diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 43c9928..85ee4d1 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.4 2000/10/16 14:26:26 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.5 2000/10/17 13:22:10 simonmar Exp $ -- -- Driver flags -- @@ -297,7 +297,8 @@ static_flags = ----------------------------------------------------------------------------- -- parse the dynamic arguments -GLOBAL_VAR(v_DynFlags, error "no dynFlags", DynFlags) +GLOBAL_VAR(v_InitDynFlags, error "no InitDynFlags", DynFlags) +GLOBAL_VAR(v_DynFlags, error "no DynFlags", DynFlags) setDynFlag f = do dfs <- readIORef v_DynFlags @@ -364,6 +365,23 @@ dynamic_flags = [ , ( "DoStgLinting", NoArg (setDynFlag Opt_DoStgLinting) ) , ( "DoUSPLinting", NoArg (setDynFlag Opt_DoUSPLinting) ) + ------ Warnings ---------------------------------------------------- + + , ( "-fwarn-duplicate-exports", NoArg (setDynFlag Opt_WarnDuplicateExports) ) + , ( "-fwarn-hi-shadowing", NoArg (setDynFlag Opt_WarnHiShadows) ) + , ( "-fwarn-incomplete-patterns", NoArg (setDynFlag Opt_WarnIncompletePatterns) ) + , ( "-fwarn-missing-fields", NoArg (setDynFlag Opt_WarnMissingFields) ) + , ( "-fwarn-missing-methods", NoArg (setDynFlag Opt_WarnMissingMethods)) + , ( "-fwarn-missing-signatures", NoArg (setDynFlag Opt_WarnMissingSigs) ) + , ( "-fwarn-name-shadowing", NoArg (setDynFlag Opt_WarnNameShadowin) ) + , ( "-fwarn-overlapping-patterns", NoArg (setDynFlag Opt_WarnOverlappingPatterns )) ) + , ( "-fwarn-simple-patterns", NoArg (setDynFlag Opt_WarnSimplePatterns)) + , ( "-fwarn-type-defaults", NoArg (setDynFlag Opt_WarnTypeDefaults) ) + , ( "-fwarn-unused-binds", NoArg (setDynFlag Opt_WarnUnusedBinds) ) + , ( "-fwarn-unused-imports", NoArg (setDynFlag Opt_WarnUnusedImports) ) + , ( "-fwarn-unused-matches", NoArg (setDynFlag Opt_WarnUnusedMatches) ) + , ( "-fwarn-deprecations", NoArg (setDynFlag Opt_WarnDeprecations) ) + ------ Machine dependant (-m) stuff --------------------------- , ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) )) @@ -447,12 +465,6 @@ build_hsc_opts = do static <- (do s <- readIORef static; if s then return "-static" else return "") - l <- readIORef hsc_lang - let lang = case l of - HscC -> "-olang=C" - HscAsm -> "-olang=asm" - HscJava -> "-olang=java" - -- get hi-file suffix hisuf <- readIORef hi_suf @@ -466,27 +478,8 @@ build_hsc_opts = do import_dirs <- readIORef import_paths package_import_dirs <- getPackageImportPath - let hi_map = "-himap=" ++ - makeHiMap import_dirs hisuf - package_import_dirs package_hisuf - split_marker - - hi_map_sep = "-himap-sep=" ++ [split_marker] - return ( filtered_opts - ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ] + ++ [ hi_vers, static, verb ] ) - -makeHiMap - (import_dirs :: [String]) - (hi_suffix :: String) - (package_import_dirs :: [String]) - (package_hi_suffix :: String) - (split_marker :: Char) - = foldr (add_dir hi_suffix) - (foldr (add_dir package_hi_suffix) "" package_import_dirs) - import_dirs - where - add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 8a80a85..2f45506 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.1 2000/10/11 15:31:43 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.2 2000/10/17 13:22:10 simonmar Exp $ -- -- GHC Driver -- @@ -16,9 +16,9 @@ import DriverState import DriverUtil import DriverFlags import TmpFiles +import Module import Config import Util -import CmdLineOpts import IOExts import Exception @@ -173,8 +173,8 @@ findDependency mod imp = do let (imp_mod, is_source) = case imp of - MINormal str -> (str, False) - MISource str -> (str, True ) + MINormal str -> (moduleNameString str, False) + MISource str -> (moduleNameString str, True ) imp_hi = imp_mod ++ '.':hisuf imp_hiboot = imp_mod ++ ".hi-boot" diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index b345755..7f91297 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -7,7 +7,8 @@ module Finder ( Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation)) newFinder, -- :: PackageConfigInfo -> IO Finder, - ModuleLocation(..) + ModuleLocation(..), + mkHomeModuleLocn ) where #include "HsVersions.h" @@ -116,28 +117,28 @@ maybeHomeModule mod_name = do lhs = basename ++ ".lhs" case lookupFM home_cache hs of { - Just path -> mkHomeModuleLocn mod_name basename path hs; + Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs; Nothing -> case lookupFM home_cache lhs of { - Just path -> mkHomeModuleLocn mod_name basename path lhs; + Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs; Nothing -> return Nothing }} -mkHomeModuleLocn mod_name basename path source_fn = do +mkHomeModuleLocn mod_name basename source_fn = do -- figure out the .hi file name: it lives in the same dir as the -- source, unless there's a -ohi flag on the command line. ohi <- readIORef output_hi hisuf <- readIORef hi_suf let hifile = case ohi of - Nothing -> path ++ '/':basename ++ hisuf + Nothing -> basename ++ hisuf Just fn -> fn -- figure out the .o file name. It also lives in the same dir -- as the source, but can be overriden by a -odir flag. - o_file <- odir_ify (path ++ '/':basename ++ '.':phaseInputExt Ln) + o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) return (Just (mkHomeModule mod_name, ModuleLocation{ diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index f101b7e..8566b7e 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.5 2000/10/11 16:26:04 simonmar Exp $ +-- $Id: Main.hs,v 1.6 2000/10/17 13:22:11 simonmar Exp $ -- -- GHC Driver program -- @@ -161,6 +161,9 @@ main = -- the rest of the arguments are "dynamic" srcs <- processArgs dynamic_flags non_static [] + -- save the "initial DynFlags" away + dyn_flags <- readIORef v_DynFlags + writeIORef v_InitDynFlags dyn_flags -- complain about any unknown flags let unknown_flags = [ f | ('-':f) <- srcs ] diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index f538da6..c28bb3f 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -110,7 +110,7 @@ import Type ( Type, mkTyConTy, mkTyConApp, mkSigmaTy, mkTyVarTys, TauType, ClassContext ) import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique ) import PrelNames -import CmdLineOpts ( DynFlags, dopt_GlasgowExts ) +import CmdLineOpts import Array alpha_tyvar = [alphaTyVar] @@ -481,7 +481,7 @@ legalOutgoingTyCon dflags be_safe tc = marshalableTyCon dflags tc marshalableTyCon dflags tc - = (dopt_GlasgowExts dflags && isUnLiftedTyCon tc) + = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) || boxedMarshalableTyCon tc boxedMarshalableTyCon tc diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index becba92..8ed2072 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -8,8 +8,6 @@ module RnEnv where -- Export everything #include "HsVersions.h" -import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches, - opt_WarnUnusedBinds, opt_WarnUnusedImports ) import HsSyn import RdrHsSyn ( RdrNameIE ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, @@ -40,6 +38,7 @@ import ListSetOps ( removeDups, equivClasses ) import Util ( thenCmp, sortLt ) import List ( nub ) import PrelNames ( mkUnboundName ) +import CmdLineOpts \end{code} @@ -319,9 +318,11 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope -- Check for duplicate names checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow -> + -- Warn about shadowing, but only in source modules (case mode of - SourceMode | opt_WarnNameShadowing -> mapRn_ (check_shadow name_env) rdr_names_w_loc + SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc other -> returnRn () ) `thenRn_` @@ -683,8 +684,9 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> \begin{code} warnUnusedModules :: [Module] -> RnM d () warnUnusedModules mods - | not opt_WarnUnusedImports = returnRn () - | otherwise = mapRn_ (addWarnRn . unused_mod . moduleName) mods + = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> + if warn then mapRn_ (addWarnRn . unused_mod . moduleName) mods + else returnRn () where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", @@ -693,19 +695,19 @@ warnUnusedModules mods warnUnusedImports :: [(Name,Provenance)] -> RnM d () warnUnusedImports names - | not opt_WarnUnusedImports - = returnRn () -- Don't force names unless necessary - | otherwise - = warnUnusedBinds names + = doptRn Opt_WarnUnusedImports `thenRn` \ warn -> + if warn then warnUnusedBinds names else return () warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () warnUnusedLocalBinds names - | not opt_WarnUnusedBinds = returnRn () - | otherwise = warnUnusedBinds [(n,LocalDef) | n<-names] + = doptRn Opt_WarnUnusedBinds `thenRn` \ warn -> + if warn then warnUnusedBinds [(n,LocalDef) | n<-names] + else returnRn () warnUnusedMatches names - | opt_WarnUnusedMatches = warnUnusedGroup [(n,LocalDef) | n<-names] - | otherwise = returnRn () + = doptRn Opt_WarnUnusedMatches `thenRn` \ warn -> + if warn then warnUnusedGroup [(n,LocalDef) | n<-names] + else returnRn () ------------------------- diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5ef1a72..f26bcf4 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -51,7 +51,7 @@ import Name ( Name, OccName, NamedThing(..), getSrcLoc, ) import Module ( Module, ModuleName, WhereFrom, moduleName ) import NameSet -import CmdLineOpts ( DynFlags, dopt_D_dump_rn_trace ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import SrcLoc ( SrcLoc, generatedSrcLoc ) import Unique ( Unique ) import FiniteMap ( FiniteMap, emptyFM, listToFM, plusFM ) @@ -85,7 +85,7 @@ ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) traceRn :: SDoc -> RnM d () traceRn msg - = doptsRn dopt_D_dump_rn_trace `thenRn` \b -> + = doptRn Opt_D_dump_rn_trace `thenRn` \b -> if b then putDocRn msg else returnRn () putDocRn :: SDoc -> RnM d () @@ -514,9 +514,9 @@ checkErrsRn (RnDown {rn_errs = errs_var}) l_down = readIORef errs_var >>= \ (warns,errs) -> return (isEmptyBag errs) -doptsRn :: (DynFlags -> Bool) -> RnM d Bool -doptsRn dopt (RnDown { rn_dflags = dflags}) l_down - = return (dopt dflags) +doptRn :: DynFlag -> RnM d Bool +doptRn dflag (RnDown { rn_dflags = dflags}) l_down + = return (dopt dflag dflags) \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 7a0c4bf..e556ead 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -10,8 +10,6 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn import CoreUnfold ( Unfolding, certainlyWillInline ) -import CmdLineOpts ( DynFlags, - dopt_D_verbose_core2core, dopt_D_dump_worker_wrapper ) import CoreLint ( beginPass, endPass ) import CoreUtils ( exprType, exprEtaExpandArity ) import MkId ( mkWorkerId ) @@ -25,6 +23,7 @@ import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), ) import Demand ( Demand, wwLazy ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) +import CmdLineOpts import WwLib import Outputable \end{code} @@ -71,8 +70,8 @@ wwTopBinds dflags us binds let { binds' = workersAndWrappers us binds }; endPass dflags "Worker Wrapper binds" - (dopt_D_dump_worker_wrapper dflags || - dopt_D_verbose_core2core dflags) + (dopt Opt_D_dump_worker_wrapper dflags || + dopt Opt_D_verbose_core2core dflags) binds' } \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index c4ede90..d4ad7e8 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -39,7 +39,6 @@ import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem, DefMeth (..) ) import Bag ( bagToList ) -import CmdLineOpts ( dopt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) @@ -52,6 +51,7 @@ import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred ) import Var ( TyVar ) import VarSet ( mkVarSet, emptyVarSet ) +import CmdLineOpts import ErrUtils ( dumpIfSet ) import Util ( count ) import Maybes ( seqMaybe, maybeToBool, orElse ) @@ -105,7 +105,7 @@ tcClassDecl1 rec_env tyvar_names fundeps class_sigs def_methods pragmas sys_names src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 - doptsTc dopt_GlasgowExts `thenTc` \ glaExts -> + doptsTc Opt_GlasgowExts `thenTc` \ glaExts -> checkTc (glaExts || length tyvar_names == 1) (classArityErr class_name) `thenTc_` @@ -211,7 +211,7 @@ tcSuperClasses clas context sc_sel_names -- only the type variable of the class decl. -- For std Haskell check that the context constrains only tyvars - doptsTc dopt_GlasgowExts `thenTc` \ glaExts -> + doptsTc Opt_GlasgowExts `thenTc` \ glaExts -> (if glaExts then returnTc () else @@ -561,7 +561,8 @@ mkDefMethRhs is_inst_decl clas inst_tys sel_id loc (DefMeth dm_id) mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth = -- No default method -- Warn only if -fwarn-missing-methods - warnTc (is_inst_decl && opt_WarnMissingMethods) + doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn -> + warnTc (is_inst_decl && warn) (omittedMethodWarn sel_id clas) `thenNF_Tc_` returnTc error_rhs where diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 94e70d6..6882991 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -47,7 +47,6 @@ import Var ( TyVar, Id, setVarName, idType, lazySetIdInfo, idInfo, tyVarKind, UVar, ) import VarSet -import VarEnv ( TyVarSubstEnv ) import Type ( Kind, Type, superKind, tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy, splitFunTys, @@ -65,7 +64,6 @@ import Name ( Name, OccName, NamedThing(..), ) import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) import Module ( Module ) -import Unify ( unifyTyListsX, matchTys ) import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..), GlobalSymbolTable, Provenance(..) ) import Unique ( pprUnique10, Unique, Uniquable(..) ) @@ -74,7 +72,6 @@ import Unique ( Uniquable(..) ) import Util ( zipEqual, zipWith3Equal, mapAccumL ) import SrcLoc ( SrcLoc ) import FastString ( FastString ) -import Maybes import Outputable import TcInstUtil ( emptyInstEnv ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 90d106e..64430f8 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -57,7 +57,6 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe, ) import TyCon ( TyCon, tyConTyVars ) import Subst ( mkTopTyVarSubst, substClasses, substTy ) -import UsageSPUtils ( unannotTy ) import VarSet ( elemVarSet, mkVarSet ) import TysWiredIn ( boolTy ) import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) @@ -71,7 +70,7 @@ import Outputable import Maybes ( maybeToBool, mapMaybe ) import ListSetOps ( minusList ) import Util -import CmdLineOpts ( opt_WarnMissingFields ) +import CmdLineOpts import HscTypes ( TyThing(..) ) \end{code} @@ -419,7 +418,8 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty let missing_fields = missingFields rbinds data_con in - checkTcM (not (opt_WarnMissingFields && not (null missing_fields))) + doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn -> + checkTcM (not (warn && not (null missing_fields))) (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_` returnNF_Tc ()) `thenNF_Tc_` diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index ef27118..d60a0a5 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -19,31 +19,28 @@ module TcInstUtil ( #include "HsVersions.h" import RnHsSyn ( RenamedMonoBinds, RenamedSig ) -import HsTypes ( toHsType ) -import CmdLineOpts ( DynFlags, dopt_AllowOverlappingInstances ) -import TcMonad -import Bag ( bagToList, Bag ) +import HscTypes ( InstEnv, ClsInstEnv, DFunId ) import Class ( Class ) -import Var ( TyVar, Id, idName ) +import Var ( TyVar, Id ) import VarSet ( unionVarSet, mkVarSet ) import VarEnv ( TyVarSubstEnv ) import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) -import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName ) +import Name ( getSrcLoc ) import SrcLoc ( SrcLoc ) import Type ( Type, ThetaType, splitTyConApp_maybe, - mkSigmaTy, splitSigmaTy, mkDictTy, splitDictTy, + splitSigmaTy, splitDictTy, tyVarsOfTypes ) -import PprType ( pprConstraint ) +import PprType ( ) import Class ( classTyCon ) import DataCon ( DataCon ) import TyCon ( TyCon, tyConDataCons ) import Outputable -import HscTypes ( InstEnv, ClsInstEnv, DFunId ) import Unify ( matchTys, unifyTyListsX ) import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM ) import Id ( idType ) import ErrUtils ( Message ) +import CmdLineOpts \end{code} @@ -369,7 +366,7 @@ addToInstEnv dflags inst_env dfun_id -- (b) they unify, and any sort of overlap is prohibited, -- (c) they unify but neither is more specific than t'other | identical - || (unifiable && not (dopt_AllowOverlappingInstances dflags)) + || (unifiable && not (dopt Opt_AllowOverlappingInstances dflags)) || (unifiable && not (ins_item_more_specific || cur_item_more_specific)) = failMaB val diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index c365b94..ade2ce6 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -51,7 +51,6 @@ import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverL import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) -import CmdLineOpts ( DynFlags, opt_PprStyle_Debug ) import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) @@ -63,13 +62,12 @@ import VarSet ( TyVarSet ) import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply, mkSplitUniqSupply, UniqSM, initUs_ ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc ) import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM ) -import UniqFM ( UniqFM, emptyUFM ) +import UniqFM ( emptyUFM ) import Unique ( Unique ) -import BasicTypes ( Unused ) +import CmdLineOpts import Outputable -import FastString ( FastString ) import IOExts ( IORef, newIORef, readIORef, writeIORef, unsafeInterleaveIO, fixIO @@ -636,9 +634,9 @@ getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt setErrCtxt down msg = down{tc_ctxt=[msg]} addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down} -doptsTc :: (DynFlags -> Bool) -> TcM Bool -doptsTc dopt (TcDown{tc_dflags=dflags}) env_down - = return (dopt dflags) +doptsTc :: DynFlag -> TcM Bool +doptsTc dflag (TcDown{tc_dflags=dflags}) env_down + = return (dopt dflag dflags) getDOptsTc :: TcM DynFlags getDOptsTc (TcDown{tc_dflags=dflags}) env_down diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 1c9a169..e40c63e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -28,7 +28,6 @@ import CmdLineOpts ( opt_IrrefutableTuples ) import DataCon ( dataConSig, dataConFieldLabels, dataConSourceArity ) -import Id ( isDataConWrapId_maybe ) import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind ) import Subst ( substTy, substClasses ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 336eeb6..45cc94c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -123,7 +123,6 @@ module TcSimplify ( #include "HsVersions.h" -import CmdLineOpts ( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults ) import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) import TcHsSyn ( TcExpr, TcId, TcMonoBinds, TcDictBinds @@ -167,6 +166,7 @@ import Util ( zipEqual, mapAccumL ) import List ( partition ) import Maybe ( fromJust ) import Maybes ( maybeToBool ) +import CmdLineOpts \end{code} @@ -848,7 +848,7 @@ tcSimplifyThetas :: ClassContext -- Wanted -> TcM ClassContext -- Needed tcSimplifyThetas wanteds - = doptsTc dopt_GlasgowExts `thenNF_Tc` \ glaExts -> + = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts -> reduceSimple [] wanteds `thenNF_Tc` \ irreds -> let -- For multi-param Haskell, check that the returned dictionaries @@ -1226,11 +1226,9 @@ addAmbigErr ambig_tv_fn dict (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict warnDefault dicts default_ty - | not opt_WarnTypeDefaults - = returnNF_Tc () + = doptsTc Opt_WarnTypeDefaults `thenTc` \ warn -> + if warn then warnTc True msg else returnNF_Tc () - | otherwise - = warnTc True msg where msg | length dicts > 1 = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index bc6f537..aa0a869 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -17,15 +17,15 @@ module TcUnify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, -- friends: import TcMonad import TypeRep ( Type(..), PredType(..) ) -- friend -import Type ( funTyCon, Kind, unboxedTypeKind, boxedTypeKind, openTypeKind, - superBoxity, typeCon, openKindCon, hasMoreBoxityInfo, +import Type ( unboxedTypeKind, boxedTypeKind, openTypeKind, + typeCon, openKindCon, hasMoreBoxityInfo, tyVarsOfType, typeKind, - mkTyVarTy, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe, + mkFunTy, splitFunTy_maybe, splitTyConApp_maybe, isNotUsgTy, splitAppTy_maybe, mkTyConApp, tidyOpenType, tidyOpenTypes, tidyTyVar ) import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity ) -import Var ( TyVar, tyVarKind, varName, isSigTyVar ) +import Var ( tyVarKind, varName, isSigTyVar ) import VarSet ( varSetElems ) import TcType ( TcType, TcTauType, TcTyVar, TcKind, newBoxityVar, newTyVarTy, newTyVarTys, tcGetTyVar, tcPutTyVar, zonkTcType