X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDynFlags.hs;h=f4975f0992f5752a457b9b0d75da79a1db980848;hb=72547264724117d689a7fa400104185557fb2a0c;hp=bebea761cd38256e087ec3697547e30203bd1a1c;hpb=46bef1c09f499c5b34a00b650614bebfa1d6ba4b;p=ghc-hetmet.git diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index bebea76..f4975f0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -17,10 +17,11 @@ module DynFlags ( GhcMode(..), isOneShot, GhcLink(..), isNoLink, PackageFlag(..), - Option(..), + Option(..), showOpt, DynLibLoader(..), fFlags, xFlags, dphPackage, + wayNames, -- ** Manipulating DynFlags defaultDynFlags, -- DynFlags @@ -57,6 +58,7 @@ module DynFlags ( getStgToDo, -- * Compiler configuration suitable for display to the user + Printable(..), compilerInfo ) where @@ -68,11 +70,7 @@ import Platform import Module import PackageConfig import PrelNames ( mAIN ) -#if defined(i386_TARGET_ARCH) || (!defined(mingw32_TARGET_OS) && !defined(darwin_TARGET_OS)) -import StaticFlags ( opt_Static ) -#endif -import StaticFlags ( opt_PIC, WayName(..), v_Ways, v_Build_tag, - v_RTS_Build_tag ) +import StaticFlags import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config @@ -185,6 +183,7 @@ data DynFlag | Opt_WarnUnusedMatches | Opt_WarnWarningsDeprecations | Opt_WarnDeprecatedFlags + | Opt_WarnDodgyExports | Opt_WarnDodgyImports | Opt_WarnOrphans | Opt_WarnTabs @@ -224,6 +223,7 @@ data DynFlag | Opt_ViewPatterns | Opt_GADTs | Opt_RelaxedPolyRec + | Opt_NPlusKPatterns | Opt_StandaloneDeriving | Opt_DeriveDataTypeable @@ -248,6 +248,7 @@ data DynFlag | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo | Opt_PostfixOperators + | Opt_TupleSections | Opt_PatternGuards | Opt_LiberalTypeSynonyms | Opt_Rank2Types @@ -310,6 +311,8 @@ data DynFlag | Opt_GenManifest | Opt_EmbedManifest | Opt_EmitExternalCore + | Opt_SharedImplib + | Opt_BuildingCabalPackage -- temporary flags | Opt_RunCPS @@ -365,7 +368,7 @@ data DynFlags = DynFlags { thisPackage :: PackageId, -- ^ name of package currently being compiled -- ways - wayNames :: [WayName], -- ^ Way flags from the command line + ways :: [Way], -- ^ Way flags from the command line buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) rtsBuildTag :: String, -- ^ The RTS \"way\" @@ -465,6 +468,9 @@ data DynFlags = DynFlags { haddockOptions :: Maybe String } +wayNames :: DynFlags -> [WayName] +wayNames = map wayName . ways + -- | The target code type of the compilation (if any). -- -- Whenever you change the target, also make sure to set 'ghcLink' to @@ -565,14 +571,12 @@ initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do -- someday these will be dynamic flags ways <- readIORef v_Ways - build_tag <- readIORef v_Build_tag - rts_build_tag <- readIORef v_RTS_Build_tag refFilesToClean <- newIORef [] refDirsToClean <- newIORef emptyFM return dflags{ - wayNames = ways, - buildTag = build_tag, - rtsBuildTag = rts_build_tag, + ways = ways, + buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), + rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, dirsToClean = refDirsToClean } @@ -648,7 +652,7 @@ defaultDynFlags = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - wayNames = panic "defaultDynFlags: No wayNames", + ways = panic "defaultDynFlags: No ways", buildTag = panic "defaultDynFlags: No buildTag", rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag", splitInfo = Nothing, @@ -689,11 +693,14 @@ defaultDynFlags = Opt_ImplicitPrelude, Opt_MonomorphismRestriction, + Opt_NPlusKPatterns, Opt_MethodSharing, Opt_DoAsmMangling, + Opt_SharedImplib, + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents @@ -850,6 +857,10 @@ data Option String -- the filepath/filename portion | Option String +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s + ----------------------------------------------------------------------------- -- Setting the optimisation level @@ -923,6 +934,7 @@ minusWOpts Opt_WarnUnusedMatches, Opt_WarnUnusedImports, Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, Opt_WarnDodgyImports ] @@ -1227,7 +1239,8 @@ dynamic_flags = [ Flag "n" (NoArg (setDynFlag Opt_DryRun)) Supported , Flag "cpp" (NoArg (setDynFlag Opt_Cpp)) Supported , Flag "F" (NoArg (setDynFlag Opt_Pp)) Supported - , Flag "#include" (HasArg (addCmdlineHCInclude)) Supported + , Flag "#include" (HasArg (addCmdlineHCInclude)) + (Deprecated "No longer has any effect") , Flag "v" (OptIntSuffix setVerbosity) Supported ------- Specific phases -------------------------------------------- @@ -1644,6 +1657,7 @@ useInstead flag turn_on fFlags :: [(String, DynFlag, Bool -> Deprecated)] fFlags = [ ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, const Supported ), + ( "warn-dodgy-exports", Opt_WarnDodgyExports, const Supported ), ( "warn-dodgy-imports", Opt_WarnDodgyImports, const Supported ), ( "warn-duplicate-exports", Opt_WarnDuplicateExports, const Supported ), ( "warn-hi-shadowing", Opt_WarnHiShadows, const Supported ), @@ -1742,6 +1756,8 @@ fFlags = [ ( "gen-manifest", Opt_GenManifest, const Supported ), ( "embed-manifest", Opt_EmbedManifest, const Supported ), ( "ext-core", Opt_EmitExternalCore, const Supported ), + ( "shared-implib", Opt_SharedImplib, const Supported ), + ( "building-cabal-package", Opt_BuildingCabalPackage, const Supported ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, const Supported ) ] @@ -1757,6 +1773,7 @@ xFlags :: [(String, DynFlag, Bool -> Deprecated)] xFlags = [ ( "CPP", Opt_Cpp, const Supported ), ( "PostfixOperators", Opt_PostfixOperators, const Supported ), + ( "TupleSections", Opt_TupleSections, const Supported ), ( "PatternGuards", Opt_PatternGuards, const Supported ), ( "UnicodeSyntax", Opt_UnicodeSyntax, const Supported ), ( "MagicHash", Opt_MagicHash, const Supported ), @@ -1794,6 +1811,8 @@ xFlags = [ ( "BangPatterns", Opt_BangPatterns, const Supported ), -- On by default: ( "MonomorphismRestriction", Opt_MonomorphismRestriction, const Supported ), + -- On by default: + ( "NPlusKPatterns", Opt_NPlusKPatterns, const Supported ), -- On by default (which is not strictly H98): ( "MonoPatBinds", Opt_MonoPatBinds, const Supported ), ( "MonoLocalBinds", Opt_MonoLocalBinds, const Supported ), @@ -1837,6 +1856,12 @@ impliedFlags , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec) -- Ditto for scoped type variables; see -- Note [Scoped tyvars] in TcBinds , (Opt_ImpredicativeTypes, Opt_RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (Opt_RecordWildCards, Opt_DisambiguateRecordFields) ] glasgowExtsFlags :: [DynFlag] @@ -1901,7 +1926,7 @@ parseDynamicNoPackageFlags dflags args = parseDynamicFlags_ dflags args False parseDynamicFlags_ :: Monad m => DynFlags -> [Located String] -> Bool -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags_ dflags args pkg_flags = do +parseDynamicFlags_ dflags0 args pkg_flags = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1918,10 +1943,23 @@ parseDynamicFlags_ dflags args pkg_flags = do flag_spec | pkg_flags = package_flags ++ dynamic_flags | otherwise = dynamic_flags - let ((leftover, errs, warns), dflags') - = runCmdLine (processArgs flag_spec args') dflags + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs flag_spec args') dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - return (dflags', leftover, warns) + + -- Cannot use -fPIC with registerised -fvia-C, because the mangler + -- isn't up to the job. We know that if hscTarget == HscC, then the + -- user has explicitly used -fvia-C, because -fasm is the default, + -- unless there is no NCG on this platform. The latter case is + -- checked when the -fPIC flag is parsed. + -- + let (pic_warns, dflags2) = + if opt_PIC && hscTarget dflags1 == HscC && cGhcUnregisterised == "NO" + then ([L noSrcSpan $ "Warning: -fvia-C is incompatible with -fPIC; ignoring -fvia-C"], + dflags1{ hscTarget = HscAsm }) + else ([], dflags1) + + return (dflags2, leftover, pic_warns ++ warns) type DynP = CmdLineP DynFlags @@ -2020,13 +2058,7 @@ ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) setPackageName :: String -> DynFlags -> DynFlags -setPackageName p - | Nothing <- unpackPackageId pid - = ghcError (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier")) - | otherwise - = \s -> s{ thisPackage = pid } - where - pid = stringToPackageId p +setPackageName p s = s{ thisPackage = stringToPackageId p } -- If we're linking a binary, then only targets that produce object -- code are allowed (requests for other target types are ignored). @@ -2346,21 +2378,24 @@ can_split = cSplitObjs == "YES" -- ----------------------------------------------------------------------------- -- Compiler Info -compilerInfo :: [(String, String)] -compilerInfo = [("Project name", cProjectName), - ("Project version", cProjectVersion), - ("Booter version", cBooterVersion), - ("Stage", cStage), - ("Interface file version", cHscIfaceFileVersion), - ("Have interpreter", cGhcWithInterpreter), - ("Object splitting", cSplitObjs), - ("Have native code generator", cGhcWithNativeCodeGen), - ("Support SMP", cGhcWithSMP), - ("Unregisterised", cGhcUnregisterised), - ("Tables next to code", cGhcEnableTablesNextToCode), - ("Win32 DLLs", cEnableWin32DLLs), - ("RTS ways", cGhcRTSWays), - ("Leading underscore", cLeadingUnderscore), - ("Debug on", show debugIsOn) +data Printable = String String + | FromDynFlags (DynFlags -> String) + +compilerInfo :: [(String, Printable)] +compilerInfo = [("Project name", String cProjectName), + ("Project version", String cProjectVersion), + ("Booter version", String cBooterVersion), + ("Stage", String cStage), + ("Have interpreter", String cGhcWithInterpreter), + ("Object splitting", String cSplitObjs), + ("Have native code generator", String cGhcWithNativeCodeGen), + ("Support SMP", String cGhcWithSMP), + ("Unregisterised", String cGhcUnregisterised), + ("Tables next to code", String cGhcEnableTablesNextToCode), + ("Win32 DLLs", String cEnableWin32DLLs), + ("RTS ways", String cGhcRTSWays), + ("Leading underscore", String cLeadingUnderscore), + ("Debug on", String (show debugIsOn)), + ("LibDir", FromDynFlags topDir) ]