Add unique package identifiers (InstalledPackageId) in the package DB

[ghc-hetmet.git] / compiler / main / DynFlags.hs

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index fce8eac..f4975f0 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -21,6 +21,7 @@ module DynFlags (
         DynLibLoader(..),
         fFlags, xFlags,
         dphPackage,
         DynLibLoader(..),
         fFlags, xFlags,
         dphPackage,

+        wayNames,

 
         -- ** Manipulating DynFlags
         defaultDynFlags,                -- DynFlags
 
         -- ** Manipulating DynFlags
         defaultDynFlags,                -- DynFlags

@@ -69,11 +70,7 @@ import Platform
 import Module
 import PackageConfig
 import PrelNames        ( mAIN )
 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
 import {-# SOURCE #-} Packages (PackageState)
 import DriverPhases     ( Phase(..), phaseInputExt )
 import Config

@@ -186,6 +183,7 @@ data DynFlag
    | Opt_WarnUnusedMatches
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags
    | Opt_WarnUnusedMatches
    | Opt_WarnWarningsDeprecations
    | Opt_WarnDeprecatedFlags

+   | Opt_WarnDodgyExports

    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
    | Opt_WarnTabs
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
    | Opt_WarnTabs

@@ -225,6 +223,7 @@ data DynFlag
    | Opt_ViewPatterns
    | Opt_GADTs
    | Opt_RelaxedPolyRec
    | Opt_ViewPatterns
    | Opt_GADTs
    | Opt_RelaxedPolyRec

+   | Opt_NPlusKPatterns

 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable
 
    | Opt_StandaloneDeriving
    | Opt_DeriveDataTypeable

@@ -249,6 +248,7 @@ data DynFlag
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PostfixOperators
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PostfixOperators

+   | Opt_TupleSections

    | Opt_PatternGuards
    | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types
    | Opt_PatternGuards
    | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types

@@ -312,6 +312,7 @@ data DynFlag
    | Opt_EmbedManifest
    | Opt_EmitExternalCore
    | Opt_SharedImplib
    | Opt_EmbedManifest
    | Opt_EmitExternalCore
    | Opt_SharedImplib

+   | Opt_BuildingCabalPackage

 
        -- temporary flags
    | Opt_RunCPS
 
        -- temporary flags
    | Opt_RunCPS

@@ -367,7 +368,7 @@ data DynFlags = DynFlags {
   thisPackage           :: PackageId,   -- ^ name of package currently being compiled
 
   -- ways
   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\"
 
   buildTag              :: String,      -- ^ The global \"way\" (e.g. \"p\" for prof)
   rtsBuildTag           :: String,      -- ^ The RTS \"way\"
 

@@ -467,6 +468,9 @@ data DynFlags = DynFlags {
   haddockOptions :: Maybe String
  }
 
   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
 -- | The target code type of the compilation (if any).
 --
 -- Whenever you change the target, also make sure to set 'ghcLink' to

@@ -567,14 +571,12 @@ initDynFlags :: DynFlags -> IO DynFlags
 initDynFlags dflags = do
  -- someday these will be dynamic flags
  ways <- readIORef v_Ways
 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{
  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
         }
         filesToClean    = refFilesToClean,
         dirsToClean     = refDirsToClean
         }

@@ -650,7 +652,7 @@ defaultDynFlags =
         packageFlags            = [],
         pkgDatabase             = Nothing,
         pkgState                = panic "no package state yet: call GHC.setSessionDynFlags",
         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,
         buildTag                = panic "defaultDynFlags: No buildTag",
         rtsBuildTag             = panic "defaultDynFlags: No rtsBuildTag",
         splitInfo               = Nothing,

@@ -691,6 +693,7 @@ defaultDynFlags =
 
             Opt_ImplicitPrelude,
             Opt_MonomorphismRestriction,
 
             Opt_ImplicitPrelude,
             Opt_MonomorphismRestriction,

+            Opt_NPlusKPatterns,

 
             Opt_MethodSharing,
 
 
             Opt_MethodSharing,
 

@@ -931,6 +934,7 @@ minusWOpts
         Opt_WarnUnusedMatches,
         Opt_WarnUnusedImports,
         Opt_WarnIncompletePatterns,
         Opt_WarnUnusedMatches,
         Opt_WarnUnusedImports,
         Opt_WarnIncompletePatterns,

+        Opt_WarnDodgyExports,

         Opt_WarnDodgyImports
       ]
 
         Opt_WarnDodgyImports
       ]
 

@@ -1235,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 "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  --------------------------------------------
   , Flag "v"              (OptIntSuffix setVerbosity) Supported
 
         ------- Specific phases  --------------------------------------------

@@ -1652,6 +1657,7 @@ useInstead flag turn_on
 fFlags :: [(String, DynFlag, Bool -> Deprecated)]
 fFlags = [
   ( "warn-dodgy-foreign-imports",       Opt_WarnDodgyForeignImports, const Supported ),
 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 ),
   ( "warn-dodgy-imports",               Opt_WarnDodgyImports, const Supported ),
   ( "warn-duplicate-exports",           Opt_WarnDuplicateExports, const Supported ),
   ( "warn-hi-shadowing",                Opt_WarnHiShadows, const Supported ),

@@ -1751,6 +1757,7 @@ fFlags = [
   ( "embed-manifest",                   Opt_EmbedManifest, const Supported ),
   ( "ext-core",                         Opt_EmitExternalCore, const Supported ),
   ( "shared-implib",                    Opt_SharedImplib, 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 )
   ]
 
   ( "implicit-import-qualified",        Opt_ImplicitImportQualified, const Supported )
   ]
 

@@ -1766,6 +1773,7 @@ xFlags :: [(String, DynFlag, Bool -> Deprecated)]
 xFlags = [
   ( "CPP",                              Opt_Cpp, const Supported ),
   ( "PostfixOperators",                 Opt_PostfixOperators, const Supported ),
 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 ),
   ( "PatternGuards",                    Opt_PatternGuards, const Supported ),
   ( "UnicodeSyntax",                    Opt_UnicodeSyntax, const Supported ),
   ( "MagicHash",                        Opt_MagicHash, const Supported ),

@@ -1803,6 +1811,8 @@ xFlags = [
   ( "BangPatterns",                     Opt_BangPatterns, const Supported ),
   -- On by default:
   ( "MonomorphismRestriction",          Opt_MonomorphismRestriction, const Supported ),
   ( "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 ),
   -- On by default (which is not strictly H98):
   ( "MonoPatBinds",                     Opt_MonoPatBinds, const Supported ),
   ( "MonoLocalBinds",                   Opt_MonoLocalBinds, const Supported ),

@@ -1846,6 +1856,12 @@ impliedFlags
     , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec)  -- Ditto for scoped type variables; see
                                                      --      Note [Scoped tyvars] in TcBinds
     , (Opt_ImpredicativeTypes,  Opt_RankNTypes)
     , (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]
   ]
 
 glasgowExtsFlags :: [DynFlag]

@@ -1910,7 +1926,7 @@ parseDynamicNoPackageFlags dflags args = parseDynamicFlags_ dflags args False
 parseDynamicFlags_ :: Monad m =>
                       DynFlags -> [Located String] -> Bool
                   -> m (DynFlags, [Located String], [Located String])
 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
   -- XXX Legacy support code
   -- We used to accept things like
   --     optdep-f  -optdepdepend

@@ -1927,10 +1943,23 @@ parseDynamicFlags_ dflags args pkg_flags = do
       flag_spec | pkg_flags = package_flags ++ dynamic_flags
                 | otherwise = dynamic_flags
 
       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
   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
 
 
 type DynP = CmdLineP DynFlags
 

@@ -2029,13 +2058,7 @@ ignorePackage p =
   upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
 
 setPackageName :: String -> DynFlags -> DynFlags
   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).
 
 -- If we're linking a binary, then only targets that produce object
 -- code are allowed (requests for other target types are ignored).

@@ -2363,7 +2386,6 @@ compilerInfo = [("Project name",                String cProjectName),
                 ("Project version",             String cProjectVersion),
                 ("Booter version",              String cBooterVersion),
                 ("Stage",                       String cStage),
                 ("Project version",             String cProjectVersion),
                 ("Booter version",              String cBooterVersion),
                 ("Stage",                       String cStage),

-                ("Interface file version",      String cHscIfaceFileVersion),

                 ("Have interpreter",            String cGhcWithInterpreter),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),
                 ("Have interpreter",            String cGhcWithInterpreter),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),