Improve handling of -fdph-* flags

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

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index e8b4f28..9e2d24b 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,14 +1,12 @@
 
------------------------------------------------------------------------------
---
+-- |
 -- Dynamic flags
 --
 --
 -- (c) The University of Glasgow 2005
 --
------------------------------------------------------------------------------
 
--- | Most flags are dynamic flags, which means they can change from
+-- Most flags are dynamic flags, which means they can change from
 -- compilation to compilation using @OPTIONS_GHC@ pragmas, and in a
 -- multi-session GHC each session can be using different dynamic
 -- flags.  Dynamic flags can also be set at the prompt in GHCi.
@@ -23,7 +21,7 @@ module DynFlags (
         Option(..),
         DynLibLoader(..),
         fFlags, xFlags,
-        DPHBackend(..),
+        dphPackage,
 
         -- ** Manipulating DynFlags
         defaultDynFlags,                -- DynFlags
@@ -331,7 +329,7 @@ data DynFlags = DynFlags {
 
   dphBackend            :: DPHBackend,
 
-  thisPackage           :: PackageId,
+  thisPackage           :: PackageId,   -- ^ name of package currently being compiled
 
   -- ways
   wayNames              :: [WayName],   -- ^ Way flags from the command line
@@ -578,7 +576,7 @@ defaultDynFlags =
         ghcUsagePath            = panic "defaultDynFlags: No ghciUsagePath",
         ghciUsagePath           = panic "defaultDynFlags: No ghciUsagePath",
         topDir                  = panic "defaultDynFlags: No topDir",
-        systemPackageConfig     = panic "defaultDynFlags: No systemPackageConfig",
+        systemPackageConfig     = panic  "no systemPackageConfig: call GHC.setSessionDynFlags",
         pgm_L                   = panic "defaultDynFlags: No pgm_L",
         pgm_P                   = panic "defaultDynFlags: No pgm_P",
         pgm_F                   = panic "defaultDynFlags: No pgm_F",
@@ -803,7 +801,16 @@ optLevelFlags
 
     , ([2],     Opt_LiberateCase)
     , ([2],     Opt_SpecConstr)
-    , ([2],     Opt_StaticArgumentTransformation)
+
+--     , ([2],     Opt_StaticArgumentTransformation)
+-- Max writes: I think it's probably best not to enable SAT with -O2 for the
+-- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
+-- several improvements to the heuristics, and I'm concerned that without
+-- those changes SAT will interfere with some attempts to write "high
+-- performance Haskell", as we saw in some posts on Haskell-Cafe earlier
+-- this year. In particular, the version in HEAD lacks the tail call
+-- criterion, so many things that look like reasonable loops will be
+-- turned into functions with extra (unneccesary) thunk creation.
 
     , ([0,1,2], Opt_DoLambdaEtaExpansion)
                 -- This one is important for a tiresome reason:
@@ -885,7 +892,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck Int{-CompilerPhase-} String -- Check for non-application of rules
                                                 -- matching this string
-  | CoreDoVectorisation DPHBackend
+  | CoreDoVectorisation PackageId
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
@@ -940,7 +947,7 @@ getCoreToDo dflags
 
     vectorisation
       = runWhen (dopt Opt_Vectorise dflags)
-        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphBackend dflags) ]
+        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
 
 
                 -- By default, we have 2 phases before phase 0.
@@ -1428,10 +1435,13 @@ dynamic_flags = [
         ------ DPH flags ----------------------------------------------------
 
   , Flag "fdph-seq"
-         (NoArg (upd (setDPHBackend DPHSeq)))
+         (NoArg (setDPHBackend DPHSeq))
          Supported
   , Flag "fdph-par"
-         (NoArg (upd (setDPHBackend DPHPar)))
+         (NoArg (setDPHBackend DPHPar))
+         Supported
+  , Flag "fdph-this"
+         (NoArg (setDPHBackend DPHThis))
          Supported
 
         ------ Compiler flags -----------------------------------------------
@@ -1691,8 +1701,15 @@ glasgowExtsFlags = [
 -- -----------------------------------------------------------------------------
 -- Parsing the dynamic flags.
 
-parseDynamicFlags :: DynFlags -> [Located String]
-                  -> IO (DynFlags, [Located String], [Located String])
+-- | Parse dynamic flags from a list of command line argument.  Returns the
+-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.
+-- Throws a 'UsageError' if errors occurred during parsing (such as unknown
+-- flags or missing arguments).
+parseDynamicFlags :: Monad m =>
+                     DynFlags -> [Located String]
+                  -> m (DynFlags, [Located String], [Located String])
+                     -- ^ Updated 'DynFlags', left-over arguments, and
+                     -- list of warnings.
 parseDynamicFlags dflags args = do
   -- XXX Legacy support code
   -- We used to accept things like
@@ -1846,20 +1863,36 @@ setOptLevel n dflags
 --    -fdicts-cheap                     always inline dictionaries
 --    -fmax-simplifier-iterations20     this is necessary sometimes
 --    -fno-spec-constr-threshold        run SpecConstr even for big loops
+--    -fno-spec-constr-count            SpecConstr as much as possible
 --
 setDPHOpt :: DynFlags -> DynFlags
 setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations  = 20
                                          , specConstrThreshold = Nothing
+                                         , specConstrCount     = Nothing
                                          })
                    `dopt_set`   Opt_DictsCheap
                    `dopt_unset` Opt_MethodSharing
 
 data DPHBackend = DPHPar
                 | DPHSeq
-
-setDPHBackend :: DPHBackend -> DynFlags -> DynFlags
-setDPHBackend backend dflags = dflags { dphBackend = backend }
-
+                | DPHThis
+        deriving(Eq, Ord, Enum, Show)
+
+setDPHBackend :: DPHBackend -> DynP ()
+setDPHBackend backend 
+  = do
+      upd $ \dflags -> dflags { dphBackend = backend }
+      mapM_ exposePackage (dph_packages backend)
+  where
+    dph_packages DPHThis = []
+    dph_packages DPHPar  = ["dph-prim-par", "dph-par"]
+    dph_packages DPHSeq  = ["dph-prim-seq", "dph-seq"]
+
+dphPackage :: DynFlags -> PackageId
+dphPackage dflags = case dphBackend dflags of
+                      DPHPar  -> dphParPackageId
+                      DPHSeq  -> dphSeqPackageId
+                      DPHThis -> thisPackage dflags
 
 setMainIs :: String -> DynP ()
 setMainIs arg