Implement auto-specialisation of imported Ids

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

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 47d9f6d..ae683f9 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -14,14 +14,19 @@
 -- flags.  Dynamic flags can also be set at the prompt in GHCi.
 module DynFlags (
         -- * Dynamic flags and associated configuration types
 -- flags.  Dynamic flags can also be set at the prompt in GHCi.
 module DynFlags (
         -- * Dynamic flags and associated configuration types

-        DOpt(..),

         DynFlag(..),
         ExtensionFlag(..),
         glasgowExtsFlags,
         flattenExtensionFlags,
         ensureFlattenedExtensionFlags,
         DynFlag(..),
         ExtensionFlag(..),
         glasgowExtsFlags,
         flattenExtensionFlags,
         ensureFlattenedExtensionFlags,

-        lopt_set_flattened,
-        lopt_unset_flattened,
+        dopt,
+        dopt_set,
+        dopt_unset,
+        xopt,
+        xopt_set,
+        xopt_unset,
+        xopt_set_flattened,
+        xopt_unset_flattened,

         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,
         DynFlags(..),
         RtsOptsEnabled(..),
         HscTarget(..), isObjectTarget, defaultObjectTarget,

@@ -184,9 +189,9 @@ data DynFlag
    | Opt_WarnMissingImportList
    | Opt_WarnMissingMethods
    | Opt_WarnMissingSigs
    | Opt_WarnMissingImportList
    | Opt_WarnMissingMethods
    | Opt_WarnMissingSigs

+   | Opt_WarnMissingLocalSigs

    | Opt_WarnNameShadowing
    | Opt_WarnOverlappingPatterns
    | Opt_WarnNameShadowing
    | Opt_WarnOverlappingPatterns

-   | Opt_WarnSimplePatterns

    | Opt_WarnTypeDefaults
    | Opt_WarnMonomorphism
    | Opt_WarnUnusedBinds
    | Opt_WarnTypeDefaults
    | Opt_WarnMonomorphism
    | Opt_WarnUnusedBinds

@@ -197,6 +202,7 @@ data DynFlag
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans
    | Opt_WarnDodgyExports
    | Opt_WarnDodgyImports
    | Opt_WarnOrphans

+   | Opt_WarnAutoOrphans

    | Opt_WarnTabs
    | Opt_WarnUnrecognisedPragmas
    | Opt_WarnDodgyForeignImports
    | Opt_WarnTabs
    | Opt_WarnUnrecognisedPragmas
    | Opt_WarnDodgyForeignImports

@@ -797,6 +803,7 @@ languageExtensions Nothing
                          -- behaviour the default, to see if anyone notices
                          -- SLPJ July 06
       -- In due course I'd like Opt_MonoLocalBinds to be on by default
                          -- behaviour the default, to see if anyone notices
                          -- SLPJ July 06
       -- In due course I'd like Opt_MonoLocalBinds to be on by default

+      -- But NB it's implied by GADTs etc

       -- SLPJ September 2010
     : languageExtensions (Just Haskell2010)
 languageExtensions (Just Haskell98)
       -- SLPJ September 2010
     : languageExtensions (Just Haskell2010)
 languageExtensions (Just Haskell98)

@@ -814,64 +821,47 @@ languageExtensions (Just Haskell2010)
        Opt_DoAndIfThenElse,
        Opt_RelaxedPolyRec]
 
        Opt_DoAndIfThenElse,
        Opt_RelaxedPolyRec]
 

--- The DOpt class is a temporary workaround, to avoid having to do
--- a mass-renaming dopt->lopt at the moment
-class DOpt a where
-    dopt :: a -> DynFlags -> Bool
-    dopt_set :: DynFlags -> a -> DynFlags
-    dopt_unset :: DynFlags -> a -> DynFlags
-
-instance DOpt DynFlag where
-    dopt = dopt'
-    dopt_set = dopt_set'
-    dopt_unset = dopt_unset'
-
-instance DOpt ExtensionFlag where
-    dopt = lopt
-    dopt_set = lopt_set
-    dopt_unset = lopt_unset
-

 -- | Test whether a 'DynFlag' is set
 -- | Test whether a 'DynFlag' is set

-dopt' :: DynFlag -> DynFlags -> Bool
-dopt' f dflags  = f `elem` (flags dflags)
+dopt :: DynFlag -> DynFlags -> Bool
+dopt f dflags  = f `elem` (flags dflags)

 
 -- | Set a 'DynFlag'
 
 -- | Set a 'DynFlag'

-dopt_set' :: DynFlags -> DynFlag -> DynFlags
-dopt_set' dfs f = dfs{ flags = f : flags dfs }
+dopt_set :: DynFlags -> DynFlag -> DynFlags
+dopt_set dfs f = dfs{ flags = f : flags dfs }

 
 -- | Unset a 'DynFlag'
 
 -- | Unset a 'DynFlag'

-dopt_unset' :: DynFlags -> DynFlag -> DynFlags
-dopt_unset' dfs f = dfs{ flags = filter (/= f) (flags dfs) }
+dopt_unset :: DynFlags -> DynFlag -> DynFlags
+dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }

 
 -- | Test whether a 'ExtensionFlag' is set
 
 -- | Test whether a 'ExtensionFlag' is set

-lopt :: ExtensionFlag -> DynFlags -> Bool
-lopt f dflags = case extensionFlags dflags of
+xopt :: ExtensionFlag -> DynFlags -> Bool
+xopt f dflags = case extensionFlags dflags of

                 Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening")
                 Right flags -> f `elem` flags
 
 -- | Set a 'ExtensionFlag'
                 Left _ -> panic ("Testing for extension flag " ++ show f ++ " before flattening")
                 Right flags -> f `elem` flags
 
 -- | Set a 'ExtensionFlag'

-lopt_set :: DynFlags -> ExtensionFlag -> DynFlags
-lopt_set dfs f = case extensionFlags dfs of
+xopt_set :: DynFlags -> ExtensionFlag -> DynFlags
+xopt_set dfs f = case extensionFlags dfs of

                  Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) }
                  Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening")
 
 -- | Set a 'ExtensionFlag'
                  Left onoffs -> dfs { extensionFlags = Left (On f : onoffs) }
                  Right _ -> panic ("Setting extension flag " ++ show f ++ " after flattening")
 
 -- | Set a 'ExtensionFlag'

-lopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-lopt_set_flattened dfs f = case extensionFlags dfs of
+xopt_set_flattened :: DynFlags -> ExtensionFlag -> DynFlags
+xopt_set_flattened dfs f = case extensionFlags dfs of

                            Left _ ->
                                panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened")
                            Right flags ->
                                dfs { extensionFlags = Right (f : delete f flags) }
 
 -- | Unset a 'ExtensionFlag'
                            Left _ ->
                                panic ("Setting extension flag " ++ show f ++ " before flattening, but expected flattened")
                            Right flags ->
                                dfs { extensionFlags = Right (f : delete f flags) }
 
 -- | Unset a 'ExtensionFlag'

-lopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
-lopt_unset dfs f = case extensionFlags dfs of
+xopt_unset :: DynFlags -> ExtensionFlag -> DynFlags
+xopt_unset dfs f = case extensionFlags dfs of

                    Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) }
                    Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening")
 
 -- | Unset a 'ExtensionFlag'
                    Left onoffs -> dfs { extensionFlags = Left (Off f : onoffs) }
                    Right _ -> panic ("Unsetting extension flag " ++ show f ++ " after flattening")
 
 -- | Unset a 'ExtensionFlag'

-lopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
-lopt_unset_flattened dfs f = case extensionFlags dfs of
+xopt_unset_flattened :: DynFlags -> ExtensionFlag -> DynFlags
+xopt_unset_flattened dfs f = case extensionFlags dfs of

                              Left _ ->
                                  panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
                              Right flags ->
                              Left _ ->
                                  panic ("Unsetting extension flag " ++ show f ++ " before flattening, but expected flattened")
                              Right flags ->

@@ -1440,9 +1430,9 @@ fFlags = [
   ( "warn-missing-import-lists",        Opt_WarnMissingImportList, nop ),
   ( "warn-missing-methods",             Opt_WarnMissingMethods, nop ),
   ( "warn-missing-signatures",          Opt_WarnMissingSigs, nop ),
   ( "warn-missing-import-lists",        Opt_WarnMissingImportList, nop ),
   ( "warn-missing-methods",             Opt_WarnMissingMethods, nop ),
   ( "warn-missing-signatures",          Opt_WarnMissingSigs, nop ),

+  ( "warn-missing-local-sigs",          Opt_WarnMissingLocalSigs, nop ),

   ( "warn-name-shadowing",              Opt_WarnNameShadowing, nop ),
   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns, nop ),
   ( "warn-name-shadowing",              Opt_WarnNameShadowing, nop ),
   ( "warn-overlapping-patterns",        Opt_WarnOverlappingPatterns, nop ),

-  ( "warn-simple-patterns",             Opt_WarnSimplePatterns, nop ),

   ( "warn-type-defaults",               Opt_WarnTypeDefaults, nop ),
   ( "warn-monomorphism-restriction",    Opt_WarnMonomorphism, nop ),
   ( "warn-unused-binds",                Opt_WarnUnusedBinds, nop ),
   ( "warn-type-defaults",               Opt_WarnTypeDefaults, nop ),
   ( "warn-monomorphism-restriction",    Opt_WarnMonomorphism, nop ),
   ( "warn-unused-binds",                Opt_WarnUnusedBinds, nop ),

@@ -1452,6 +1442,7 @@ fFlags = [
   ( "warn-deprecations",                Opt_WarnWarningsDeprecations, nop ),
   ( "warn-deprecated-flags",            Opt_WarnDeprecatedFlags, nop ),
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),
   ( "warn-deprecations",                Opt_WarnWarningsDeprecations, nop ),
   ( "warn-deprecated-flags",            Opt_WarnDeprecatedFlags, nop ),
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),

+  ( "warn-auto-orphans",                Opt_WarnAutoOrphans, nop ),

   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
   ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
   ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),

@@ -1578,8 +1569,7 @@ xFlags = [
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
   ( "RankNTypes",                       Opt_RankNTypes, nop ),
   ( "LiberalTypeSynonyms",              Opt_LiberalTypeSynonyms, nop ),
   ( "Rank2Types",                       Opt_Rank2Types, nop ),
   ( "RankNTypes",                       Opt_RankNTypes, nop ),

-  ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, 
-        \_ -> deprecate "impredicative polymorphism will be simplified or removed in GHC 6.14" ),
+  ( "ImpredicativeTypes",               Opt_ImpredicativeTypes, nop), 

   ( "TypeOperators",                    Opt_TypeOperators, nop ),
   ( "RecursiveDo",                      Opt_RecursiveDo,
     deprecatedForExtension "DoRec"),
   ( "TypeOperators",                    Opt_TypeOperators, nop ),
   ( "RecursiveDo",                      Opt_RecursiveDo,
     deprecatedForExtension "DoRec"),

@@ -1673,7 +1663,6 @@ impliedFlags
 
     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
 
     , (Opt_GADTs,                  Opt_MonoLocalBinds)
     , (Opt_TypeFamilies,           Opt_MonoLocalBinds)

-    , (Opt_FunctionalDependencies, Opt_MonoLocalBinds)

 
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
                                                     -- all over the place
 
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
                                                     -- all over the place

@@ -1770,9 +1759,9 @@ minuswRemovesOpts
     = minusWallOpts ++
       [Opt_WarnImplicitPrelude,
        Opt_WarnIncompletePatternsRecUpd,
     = minusWallOpts ++
       [Opt_WarnImplicitPrelude,
        Opt_WarnIncompletePatternsRecUpd,

-       Opt_WarnSimplePatterns,

        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,
        Opt_WarnMonomorphism,
        Opt_WarnUnrecognisedPragmas,

+       Opt_WarnAutoOrphans,

        Opt_WarnTabs
       ]
 
        Opt_WarnTabs
       ]
 

@@ -1883,7 +1872,7 @@ setLanguage l = upd (\dfs -> dfs { language = Just l })
 
 --------------------------
 setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()
 
 --------------------------
 setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP ()

-setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f)
+setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f)

                         ; mapM_ setExtensionFlag deps }
   where
     deps = [ d | (f', d) <- impliedFlags, f' == f ]
                         ; mapM_ setExtensionFlag deps }
   where
     deps = [ d | (f', d) <- impliedFlags, f' == f ]

@@ -1893,7 +1882,7 @@ setExtensionFlag f = do { upd (\dfs -> lopt_set dfs f)
         -- When you un-set f, however, we don't un-set the things it implies
         --      (except for -fno-glasgow-exts, which is treated specially)
 
         -- When you un-set f, however, we don't un-set the things it implies
         --      (except for -fno-glasgow-exts, which is treated specially)
 

-unSetExtensionFlag f = upd (\dfs -> lopt_unset dfs f)
+unSetExtensionFlag f = upd (\dfs -> xopt_unset dfs f)

 
 --------------------------
 setDumpFlag' :: DynFlag -> DynP ()
 
 --------------------------
 setDumpFlag' :: DynFlag -> DynP ()

@@ -2298,6 +2287,7 @@ compilerInfo = [("Project name",                String cProjectName),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),
                 ("Have llvm code generator",    String cGhcWithLlvmCodeGen),
                 ("Object splitting",            String cSplitObjs),
                 ("Have native code generator",  String cGhcWithNativeCodeGen),
                 ("Have llvm code generator",    String cGhcWithLlvmCodeGen),

+                ("Use archives for ghci",       String (show cUseArchivesForGhci)),

                 ("Support SMP",                 String cGhcWithSMP),
                 ("Unregisterised",              String cGhcUnregisterised),
                 ("Tables next to code",         String cGhcEnableTablesNextToCode),
                 ("Support SMP",                 String cGhcWithSMP),
                 ("Unregisterised",              String cGhcUnregisterised),
                 ("Tables next to code",         String cGhcEnableTablesNextToCode),