Add -fsimplifier-phases option
[ghc-hetmet.git] / compiler / main / DynFlags.hs
index 4d3cb46..359ea39 100644 (file)
@@ -126,6 +126,7 @@ data DynFlag
    | Opt_D_dump_rn
    | Opt_D_dump_simpl
    | Opt_D_dump_simpl_iterations
+   | Opt_D_dump_simpl_phases
    | Opt_D_dump_spec
    | Opt_D_dump_prep
    | Opt_D_dump_stg
@@ -224,12 +225,14 @@ data DynFlag
    | Opt_KindSignatures
    | Opt_PatternSignatures
    | Opt_ParallelListComp
+   | Opt_TransformListComp
    | Opt_GeneralizedNewtypeDeriving
    | Opt_RecursiveDo
    | Opt_PatternGuards
    | Opt_LiberalTypeSynonyms
    | Opt_Rank2Types
    | Opt_RankNTypes
+   | Opt_ImpredicativeTypes
    | Opt_TypeOperators
 
    | Opt_PrintExplicitForalls
@@ -297,10 +300,12 @@ data DynFlags = DynFlags {
   extCoreName          :: String,      -- name of the .core output file
   verbosity            :: Int,         -- verbosity level
   optLevel             :: Int,         -- optimisation level
+  simplPhases           :: Int,         -- number of simplifier phases
   maxSimplIterations    :: Int,                -- max simplifier iterations
   ruleCheck            :: Maybe String,
 
-  specThreshold                :: Int,         -- Threshold for function specialisation
+  specConstrThreshold   :: Maybe Int,  -- Threshold for SpecConstr
+  liberateCaseThreshold :: Maybe Int,   -- Threshold for LiberateCase 
 
   stolen_x86_regs      :: Int,         
   cmdlineHcIncludes    :: [String],    -- -#includes
@@ -433,7 +438,7 @@ data GhcLink        -- What to do in the link step, if there is one
   | LinkBinary         -- Link object code into a binary
   | LinkInMemory        -- Use the in-memory dynamic linker
   | LinkDynLib         -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)
-  deriving Eq
+  deriving (Eq, Show)
 
 isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True
@@ -475,9 +480,11 @@ defaultDynFlags =
        extCoreName             = "",
        verbosity               = 0, 
        optLevel                = 0,
+        simplPhases             = 2,
        maxSimplIterations      = 4,
        ruleCheck               = Nothing,
-       specThreshold           = 200,
+       specConstrThreshold     = Just 200,
+        liberateCaseThreshold   = Just 200,
        stolen_x86_regs         = 4,
        cmdlineHcIncludes       = [],
        importPaths             = ["."],
@@ -773,6 +780,7 @@ getCoreToDo dflags
   | otherwise = core_todo
   where
     opt_level            = optLevel dflags
+    phases        = simplPhases dflags
     max_iter             = maxSimplIterations dflags
     strictness    = dopt Opt_Strictness dflags
     full_laziness = dopt Opt_FullLaziness dflags
@@ -782,17 +790,33 @@ getCoreToDo dflags
     rule_check    = ruleCheck dflags
     vectorisation = dopt Opt_Vectorise dflags
 
-    core_todo = 
-     if opt_level == 0 then
-      [
-       CoreDoSimplify (SimplPhase 0) [
-           MaxSimplifierIterations max_iter
-       ]
-      ]
-     else {- opt_level >= 1 -} [ 
+    maybe_rule_check phase | Just s <- rule_check = CoreDoRuleCheck phase s
+                           | otherwise            = CoreDoNothing
+
+    simpl_phase phase iter = CoreDoPasses
+                               [ CoreDoSimplify (SimplPhase phase) [
+                                   MaxSimplifierIterations iter
+                                 ],
+                                 maybe_rule_check phase
+                               ]
+
+                -- By default, we have 2 phases before phase 0.
+
+               -- Want to run with inline phase 2 after the specialiser to give
+               -- maximum chance for fusion to work before we inline build/augment
+               -- in phase 1.  This made a difference in 'ansi' where an 
+               -- overloaded function wasn't inlined till too late.
+
+               -- Need phase 1 so that build/augment get 
+               -- inlined.  I found that spectral/hartel/genfft lost some useful
+               -- strictness in the function sumcode' if augment is not inlined
+               -- before strictness analysis runs
+    simpl_phases = CoreDoPasses [ simpl_phase phase max_iter
+                                  | phase <- [phases, phases-1 .. 1] ]
+
 
        -- initial simplify: mk specialiser happy: minimum effort please
-       CoreDoSimplify SimplGently [
+    simpl_gently = CoreDoSimplify SimplGently [
                        --      Simplify "gently"
                        -- Don't inline anything till full laziness has bitten
                        -- In particular, inlining wrappers inhibits floating
@@ -806,16 +830,19 @@ getCoreToDo dflags
             NoCaseOfCase,      -- Don't do case-of-case transformations.
                                -- This makes full laziness work better
            MaxSimplifierIterations max_iter
-       ],
+       ]
 
+    core_todo = 
+     if opt_level == 0 then
+       [simpl_phase 0 max_iter]
+     else {- opt_level >= 1 -} [ 
+
+       -- initial simplify: mk specialiser happy: minimum effort please
+        simpl_gently,
 
         -- We run vectorisation here for now, but we might also try to run
         -- it later
-        runWhen vectorisation (CoreDoPasses [
-                  CoreDoVectorisation,
-                  CoreDoSimplify SimplGently
-                                  [NoCaseOfCase,
-                                   MaxSimplifierIterations max_iter]]),
+        runWhen vectorisation (CoreDoPasses [ CoreDoVectorisation, simpl_gently]),
 
        -- Specialisation is best done before full laziness
        -- so that overloaded functions have all their dictionary lambdas manifest
@@ -825,29 +852,11 @@ getCoreToDo dflags
 
        CoreDoFloatInwards,
 
-       CoreDoSimplify (SimplPhase 2) [
-               -- Want to run with inline phase 2 after the specialiser to give
-               -- maximum chance for fusion to work before we inline build/augment
-               -- in phase 1.  This made a difference in 'ansi' where an 
-               -- overloaded function wasn't inlined till too late.
-          MaxSimplifierIterations max_iter
-       ],
-       case rule_check of { Just pat -> CoreDoRuleCheck 2 pat; Nothing -> CoreDoNothing },
-
-       CoreDoSimplify (SimplPhase 1) [
-               -- Need inline-phase2 here so that build/augment get 
-               -- inlined.  I found that spectral/hartel/genfft lost some useful
-               -- strictness in the function sumcode' if augment is not inlined
-               -- before strictness analysis runs
-          MaxSimplifierIterations max_iter
-       ],
-       case rule_check of { Just pat -> CoreDoRuleCheck 1 pat; Nothing -> CoreDoNothing },
+        simpl_phases,
 
-       CoreDoSimplify (SimplPhase 0) [
                -- Phase 0: allow all Ids to be inlined now
                -- This gets foldr inlined before strictness analysis
 
-          MaxSimplifierIterations 3
                -- At least 3 iterations because otherwise we land up with
                -- huge dead expressions because of an infelicity in the 
                -- simpifier.   
@@ -855,9 +864,8 @@ getCoreToDo dflags
                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
                -- Don't stop now!
+       simpl_phase 0 (max max_iter 3),
 
-       ],
-       case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
 
 #ifdef OLD_STRICTNESS
        CoreDoOldStrictness,
@@ -866,9 +874,8 @@ getCoreToDo dflags
                CoreDoStrictness,
                CoreDoWorkerWrapper,
                CoreDoGlomBinds,
-               CoreDoSimplify (SimplPhase 0) [
-                  MaxSimplifierIterations max_iter
-               ]]),
+                simpl_phase 0 max_iter
+                ]),
 
        runWhen full_laziness 
          (CoreDoFloatOutwards (FloatOutSw False    -- Not lambdas
@@ -887,29 +894,23 @@ getCoreToDo dflags
 
        CoreDoFloatInwards,
 
-       case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+       maybe_rule_check 0,
 
                -- Case-liberation for -O2.  This should be after
                -- strictness analysis and the simplification which follows it.
        runWhen liberate_case (CoreDoPasses [
            CoreLiberateCase,
-           CoreDoSimplify (SimplPhase 0) [
-                 MaxSimplifierIterations max_iter
-           ] ]),       -- Run the simplifier after LiberateCase to vastly 
+            simpl_phase 0 max_iter
+            ]),         -- Run the simplifier after LiberateCase to vastly 
                        -- reduce the possiblility of shadowing
                        -- Reason: see Note [Shadowing] in SpecConstr.lhs
 
        runWhen spec_constr CoreDoSpecConstr,
 
-       case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
+        maybe_rule_check 0,
 
        -- Final clean-up simplification:
-       CoreDoSimplify (SimplPhase 0) [
-         MaxSimplifierIterations max_iter
-       ],
-
-       case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing }
-
+        simpl_phase 0 max_iter
      ]
 
 -- -----------------------------------------------------------------------------
@@ -1079,6 +1080,7 @@ dynamic_flags = [
   ,  ( "ddump-rn",              setDumpFlag Opt_D_dump_rn)
   ,  ( "ddump-simpl",           setDumpFlag Opt_D_dump_simpl)
   ,  ( "ddump-simpl-iterations", setDumpFlag Opt_D_dump_simpl_iterations)
+  ,  ( "ddump-simpl-phases",     setDumpFlag Opt_D_dump_simpl_phases)
   ,  ( "ddump-spec",            setDumpFlag Opt_D_dump_spec)
   ,  ( "ddump-prep",            setDumpFlag Opt_D_dump_prep)
   ,  ( "ddump-stg",             setDumpFlag Opt_D_dump_stg)
@@ -1135,12 +1137,19 @@ dynamic_flags = [
   ,  ( "O"     , OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
                -- If the number is missing, use 1
 
+  ,  ( "fsimplifier-phases",         IntSuffix (\n ->
+                upd (\dfs -> dfs{ simplPhases = n })) )
   ,  ( "fmax-simplifier-iterations", IntSuffix (\n -> 
                upd (\dfs -> dfs{ maxSimplIterations = n })) )
 
-       -- liberate-case-threshold is an old flag for '-fspec-threshold'
-  ,  ( "fspec-threshold",          IntSuffix (\n -> upd (\dfs -> dfs{ specThreshold = n })))
-  ,  ( "fliberate-case-threshold", IntSuffix (\n -> upd (\dfs -> dfs{ specThreshold = n })))
+  ,  ( "fspec-constr-threshold",      IntSuffix (\n ->
+                upd (\dfs -> dfs{ specConstrThreshold = Just n })))
+  ,  ( "fno-spec-constr-threshold",   NoArg (
+                upd (\dfs -> dfs{ specConstrThreshold = Nothing })))
+  ,  ( "fliberate-case-threshold",    IntSuffix (\n ->
+                upd (\dfs -> dfs{ liberateCaseThreshold = Just n })))
+  ,  ( "fno-liberate-case-threshold", NoArg (
+                upd (\dfs -> dfs{ liberateCaseThreshold = Nothing })))
 
   ,  ( "frule-check",     SepArg (\s -> upd (\dfs -> dfs{ ruleCheck = Just s })))
   ,  ( "fcontext-stack"        , IntSuffix $ \n -> upd $ \dfs -> dfs{ ctxtStkDepth = n })
@@ -1275,11 +1284,13 @@ xFlags = [
   ( "PatternSignatures",                Opt_PatternSignatures ),
   ( "EmptyDataDecls",                   Opt_EmptyDataDecls ),
   ( "ParallelListComp",                 Opt_ParallelListComp ),
+  ( "TransformListComp",                Opt_TransformListComp ),
   ( "ForeignFunctionInterface",         Opt_ForeignFunctionInterface ),
   ( "UnliftedFFITypes",                 Opt_UnliftedFFITypes ),
   ( "LiberalTypeSynonyms",             Opt_LiberalTypeSynonyms ),
   ( "Rank2Types",                       Opt_Rank2Types ),
   ( "RankNTypes",                       Opt_RankNTypes ),
+  ( "ImpredicativeTypes",              Opt_ImpredicativeTypes ),
   ( "TypeOperators",                    Opt_TypeOperators ),
   ( "RecursiveDo",                      Opt_RecursiveDo ),
   ( "Arrows",                           Opt_Arrows ),
@@ -1328,9 +1339,9 @@ glasgowExtsFlags = [
              Opt_PrintExplicitForalls
            , Opt_ForeignFunctionInterface
            , Opt_UnliftedFFITypes
-                  , Opt_GADTs
-                  , Opt_ImplicitParams 
-                  , Opt_ScopedTypeVariables
+          , Opt_GADTs
+          , Opt_ImplicitParams 
+          , Opt_ScopedTypeVariables
            , Opt_UnboxedTuples
            , Opt_TypeSynonymInstances
            , Opt_StandaloneDeriving
@@ -1340,13 +1351,14 @@ glasgowExtsFlags = [
            , Opt_ConstrainedClassMethods
            , Opt_MultiParamTypeClasses
            , Opt_FunctionalDependencies
-                  , Opt_MagicHash
+          , Opt_MagicHash
            , Opt_PolymorphicComponents
            , Opt_ExistentialQuantification
            , Opt_UnicodeSyntax
            , Opt_PatternGuards
            , Opt_LiberalTypeSynonyms
            , Opt_RankNTypes
+           , Opt_ImpredicativeTypes
            , Opt_TypeOperators
            , Opt_RecursiveDo
            , Opt_ParallelListComp
@@ -1354,7 +1366,7 @@ glasgowExtsFlags = [
            , Opt_KindSignatures
            , Opt_PatternSignatures
            , Opt_GeneralizedNewtypeDeriving
-                  , Opt_TypeFamilies ]
+          , Opt_TypeFamilies ]
 
 ------------------
 isFlag :: [(String,a)] -> String -> Bool