CoreMonad: add lookupOrigCoreM, modeled after IfaceEnv.lookupOrig
[ghc-hetmet.git] / compiler / simplCore / CoreMonad.lhs
index e3dbf3a..67a0991 100644 (file)
@@ -10,7 +10,6 @@ module CoreMonad (
     -- * Configuration of the core-to-core passes
     CoreToDo(..),
     SimplifierMode(..),
-    SimplifierSwitch(..),
     FloatOutSwitches(..),
     getCoreToDo, dumpSimplPhase,
 
@@ -44,6 +43,8 @@ module CoreMonad (
     debugTraceMsg, debugTraceMsgS,
     dumpIfSet_dyn, 
 
+    lookupOrigCoreM,
+
 #ifdef GHCI
     -- * Getting 'Name's
     thNameToGhcName
@@ -59,11 +60,11 @@ import CoreUtils
 import CoreLint                ( lintCoreBindings )
 import PrelNames        ( iNTERACTIVE )
 import HscTypes
-import Module           ( PackageId, Module )
+import Module           ( Module )
 import DynFlags
 import StaticFlags     
 import Rules            ( RuleBase )
-import BasicTypes      ( CompilerPhase )
+import BasicTypes       ( CompilerPhase(..) )
 import Annotations
 import Id              ( Id )
 
@@ -79,6 +80,7 @@ import Bag
 import Maybes
 import UniqSupply
 import UniqFM       ( UniqFM, mapUFM, filterUFM )
+import MonadUtils
 
 import Util            ( split )
 import Data.List       ( intersperse )
@@ -90,6 +92,11 @@ import Data.Word
 import Control.Monad
 
 import Prelude hiding   ( read )
+import OccName
+import IfaceEnv
+import Name
+import SrcLoc
+import Control.Exception.Base
 
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
@@ -185,8 +192,8 @@ displayLintResults dflags pass warns errs binds
 showLintWarnings :: CoreToDo -> Bool
 -- Disable Lint warnings on the first simplifier pass, because
 -- there may be some INLINE knots still tied, which is tiresomely noisy
-showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
-showLintWarnings _                                     = True
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
 \end{code}
 
 
@@ -203,10 +210,9 @@ data CoreToDo           -- These are diff core-to-core passes,
                         -- as many times as you like.
 
   = CoreDoSimplify      -- The core-to-core simplifier.
+        Int                    -- Max iterations
         SimplifierMode
-       Int                    -- Max iterations
-        [SimplifierSwitch]     -- Each run of the simplifier can take a different
-                               -- set of simplifier-specific flags.
+
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
@@ -220,7 +226,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
-  | CoreDoVectorisation PackageId
+  | CoreDoVectorisation
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
@@ -241,10 +247,10 @@ coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
 coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
 coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
 coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse 
-coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
-coreDumpFlag CoreDesugar             = Just Opt_D_dump_ds 
-coreDumpFlag CoreTidy                = Just Opt_D_dump_simpl
-coreDumpFlag CorePrep                = Just Opt_D_dump_prep
+coreDumpFlag CoreDoVectorisation      = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds 
+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
 
 coreDumpFlag CoreDoPrintCore         = Nothing
 coreDumpFlag (CoreDoRuleCheck {})    = Nothing
@@ -253,8 +259,8 @@ coreDumpFlag CoreDoGlomBinds         = Nothing
 coreDumpFlag (CoreDoPasses {})       = Nothing
 
 instance Outputable CoreToDo where
-  ppr (CoreDoSimplify md n _)  = ptext (sLit "Simplifier") 
-                                 <+> ppr md
+  ppr (CoreDoSimplify n md)  = ptext (sLit "Simplifier")
+                               <+> ppr md
                                  <+> ptext (sLit "max-iterations=") <> int n
   ppr CoreDoFloatInwards       = ptext (sLit "Float inwards")
   ppr (CoreDoFloatOutwards f)  = ptext (sLit "Float out") <> parens (ppr f)
@@ -265,9 +271,9 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecialising       = ptext (sLit "Specialise")
   ppr CoreDoSpecConstr         = ptext (sLit "SpecConstr")
   ppr CoreCSE                  = ptext (sLit "Common sub-expression")
-  ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
-  ppr CoreDesugar             = ptext (sLit "Desugar")
-  ppr CoreTidy                        = ptext (sLit "Tidy Core")
+  ppr CoreDoVectorisation      = ptext (sLit "Vectorisation")
+  ppr CoreDesugar              = ptext (sLit "Desugar")
+  ppr CoreTidy                 = ptext (sLit "Tidy Core")
   ppr CorePrep                        = ptext (sLit "CorePrep")
   ppr CoreDoPrintCore          = ptext (sLit "Print core")
   ppr (CoreDoRuleCheck {})     = ptext (sLit "Rule check")
@@ -278,50 +284,56 @@ instance Outputable CoreToDo where
 
 \begin{code}
 data SimplifierMode             -- See comments in SimplMonad
-  = SimplGently
-       { sm_rules :: Bool      -- Whether RULES are enabled 
-        , sm_inline :: Bool }  -- Whether inlining is enabled
-
-  | SimplPhase 
-        { sm_num :: Int          -- Phase number; counts downward so 0 is last phase
-        , sm_names :: [String] }  -- Name(s) of the phase
+  = SimplMode
+        { sm_names      :: [String] -- Name(s) of the phase
+        , sm_phase      :: CompilerPhase
+        , sm_rules      :: Bool     -- Whether RULES are enabled
+        , sm_inline     :: Bool     -- Whether inlining is enabled
+        , sm_case_case  :: Bool     -- Whether case-of-case is enabled
+        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+        }
 
 instance Outputable SimplifierMode where
-    ppr (SimplPhase { sm_num = n, sm_names = ss })
-       = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
-    ppr (SimplGently { sm_rules = r, sm_inline = i }) 
-       = ptext (sLit "gentle") <> 
-           brackets (pp_flag r (sLit "rules") <> comma <>
-                     pp_flag i (sLit "inline"))
+    ppr (SimplMode { sm_phase = p, sm_names = ss
+                   , sm_rules = r, sm_inline = i
+                   , sm_eta_expand = eta, sm_case_case = cc })
+       = ptext (sLit "SimplMode") <+> braces (
+         sep [ ptext (sLit "Phase =") <+> ppr p <+>
+               brackets (text (concat $ intersperse "," ss)) <> comma
+             , pp_flag i   (sLit "inline") <> comma
+             , pp_flag r   (sLit "rules") <> comma
+             , pp_flag eta (sLit "eta-expand") <> comma
+             , pp_flag cc  (sLit "case-of-case") ])
         where
            pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
-
-data SimplifierSwitch
-  = NoCaseOfCase
 \end{code}
 
 
 \begin{code}
 data FloatOutSwitches = FloatOutSwitches {
-        floatOutLambdas :: Bool,     -- ^ True <=> float lambdas to top level
-        floatOutConstants :: Bool,   -- ^ True <=> float constants to top level,
-                                     --            even if they do not escape a lambda
-        floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
+  floatOutLambdas   :: Maybe Int,  -- ^ Just n <=> float lambdas to top level, if
+                                   -- doing so will abstract over n or fewer 
+                                   -- value variables
+                                  -- Nothing <=> float all lambdas to top level,
+                                   --             regardless of how many free variables
+                                   -- Just 0 is the vanilla case: float a lambda
+                                   --    iff it has no free vars
+
+  floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
+                                   --            even if they do not escape a lambda
+  floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
                                             --            based on arity information.
-    }
+  }
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
 
 pprFloatOutSwitches :: FloatOutSwitches -> SDoc
-pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
-                     <+> pp_not (floatOutConstants sw) <+> text "constants"
-  where
-    pp_not True  = empty
-    pp_not False = text "not"
-
--- | Switches that specify the minimum amount of floating out
--- gentleFloatOutSwitches :: FloatOutSwitches
--- gentleFloatOutSwitches = FloatOutSwitches False False
+pprFloatOutSwitches sw 
+  = ptext (sLit "FOS") <+> (braces $
+     sep $ punctuate comma $ 
+     [ ptext (sLit "Lam =")    <+> ppr (floatOutLambdas sw)
+     , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
+     , ptext (sLit "PAPs =")   <+> ppr (floatOutPartialApplications sw) ])
 \end{code}
 
 
@@ -336,36 +348,54 @@ getCoreToDo :: DynFlags -> [CoreToDo]
 getCoreToDo dflags
   = core_todo
   where
-    opt_level     = optLevel dflags
-    phases        = simplPhases dflags
+    opt_level     = optLevel           dflags
+    phases        = simplPhases        dflags
     max_iter      = maxSimplIterations dflags
-    strictness    = dopt Opt_Strictness dflags
-    full_laziness = dopt Opt_FullLaziness dflags
-    do_specialise = dopt Opt_Specialise dflags
-    do_float_in   = dopt Opt_FloatIn dflags
-    cse           = dopt Opt_CSE dflags
-    spec_constr   = dopt Opt_SpecConstr dflags
-    liberate_case = dopt Opt_LiberateCase dflags
-    rule_check    = ruleCheck dflags
+    rule_check    = ruleCheck          dflags
+    strictness    = dopt Opt_Strictness                  dflags
+    full_laziness = dopt Opt_FullLaziness                dflags
+    do_specialise = dopt Opt_Specialise                  dflags
+    do_float_in   = dopt Opt_FloatIn                     dflags          
+    cse           = dopt Opt_CSE                          dflags
+    spec_constr   = dopt Opt_SpecConstr                   dflags
+    liberate_case = dopt Opt_LiberateCase                 dflags
     static_args   = dopt Opt_StaticArgumentTransformation dflags
+    rules_on      = dopt Opt_EnableRewriteRules           dflags
+    eta_expand_on = dopt Opt_DoLambdaEtaExpansion         dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 
     maybe_strictness_before phase
       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
 
+    base_mode = SimplMode { sm_phase      = panic "base_mode"
+                          , sm_names      = []
+                          , sm_rules      = rules_on
+                          , sm_eta_expand = eta_expand_on
+                          , sm_inline     = True
+                          , sm_case_case  = True }
+
     simpl_phase phase names iter
       = CoreDoPasses
-          [ maybe_strictness_before phase
-          , CoreDoSimplify (SimplPhase phase names) 
-                           iter []
-          , maybe_rule_check phase
-          ]
+      $   [ maybe_strictness_before phase
+          , CoreDoSimplify iter
+                (base_mode { sm_phase = Phase phase
+                           , sm_names = names })
+
+          , maybe_rule_check (Phase phase) ]
+
+          -- Vectorisation can introduce a fair few common sub expressions involving 
+          --  DPH primitives. For example, see the Reverse test from dph-examples.
+          --  We need to eliminate these common sub expressions before their definitions
+          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings, 
+          --  so we also run simpl_gently to inline them.
+      ++  (if dopt Opt_Vectorise dflags && phase == 3
+           then [CoreCSE, simpl_gently]
+           else [])
 
     vectorisation
-      = runWhen (dopt Opt_Vectorise dflags)
-        $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
-
+      = runWhen (dopt Opt_Vectorise dflags) $
+          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
 
                 -- By default, we have 2 phases before phase 0.
 
@@ -379,21 +409,18 @@ getCoreToDo dflags
                 -- strictness in the function sumcode' if augment is not inlined
                 -- before strictness analysis runs
     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
-                                  | phase <- [phases, phases-1 .. 1] ]
+                                | phase <- [phases, phases-1 .. 1] ]
 
 
         -- initial simplify: mk specialiser happy: minimum effort please
-    simpl_gently = CoreDoSimplify 
-                       (SimplGently { sm_rules = True, sm_inline = False })
-                         -- See Note [Gentle mode] and
-                         -- Note [RULEs enabled in SimplGently] in SimplUtils
-                       max_iter
-                       [
-
-
-            NoCaseOfCase        -- Don't do case-of-case transformations.
-                                -- This makes full laziness work better
-        ]
+    simpl_gently = CoreDoSimplify max_iter
+                       (base_mode { sm_phase = InitialPhase
+                                  , sm_names = ["Gentle"]
+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
+                                  , sm_inline = False
+                                  , sm_case_case = False })
+                          -- Don't do case-of-case transformations.
+                          -- This makes full laziness work better
 
     core_todo =
      if opt_level == 0 then
@@ -420,7 +447,7 @@ getCoreToDo dflags
 
         runWhen full_laziness $
            CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = False,
+                                 floatOutLambdas   = Just 0,
                                  floatOutConstants = True,
                                  floatOutPartialApplications = False },
                -- Was: gentleFloatOutSwitches  
@@ -466,7 +493,7 @@ getCoreToDo dflags
 
         runWhen full_laziness $
            CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = False,
+                                 floatOutLambdas   = floatLamArgs dflags,
                                  floatOutConstants = True,
                                  floatOutPartialApplications = True },
                 -- nofib/spectral/hartel/wang doubles in speed if you
@@ -483,7 +510,7 @@ getCoreToDo dflags
 
         runWhen do_float_in CoreDoFloatInwards,
 
-        maybe_rule_check 0,
+        maybe_rule_check (Phase 0),
 
                 -- Case-liberation for -O2.  This should be after
                 -- strictness analysis and the simplification which follows it.
@@ -496,7 +523,7 @@ getCoreToDo dflags
 
         runWhen spec_constr CoreDoSpecConstr,
 
-        maybe_rule_check 0,
+        maybe_rule_check (Phase 0),
 
         -- Final clean-up simplification:
         simpl_phase 0 ["final"] max_iter
@@ -531,17 +558,32 @@ dumpSimplPhase dflags mode
                 _        -> phase_name s
 
     phase_num :: Int -> Bool
-    phase_num n = case mode of
-                    SimplPhase k _ -> n == k
-                    _              -> False
+    phase_num n = case sm_phase mode of
+                    Phase k -> n == k
+                    _       -> False
 
     phase_name :: String -> Bool
-    phase_name s = case mode of
-                     SimplGently {}               -> s == "gentle"
-                     SimplPhase { sm_names = ss } -> s `elem` ss
+    phase_name s = s `elem` sm_names mode
 \end{code}
 
 
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification.  Two reasons:
+
+  * We really want the class-op cancellation to happen:
+        op (df d1 d2) --> $cop3 d1 d2
+    because this breaks the mutual recursion between 'op' and 'df'
+
+  * I wanted the RULE
+        lift String ===> ...
+    to work in Template Haskell when simplifying
+    splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating.  So use phase control
+to switch off those rules until after floating.
+
+
 %************************************************************************
 %*                                                                     *
              Counting and logging
@@ -1086,3 +1128,29 @@ thNameToGhcName th_name = do
     liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
 #endif
 \end{code}
+
+\begin{code}
+updNameCache' :: (NameCache -> (NameCache, a)) -> CoreM a
+updNameCache' upd_fn = do
+  HscEnv { hsc_NC = nc_var } <- getHscEnv
+  r  <- liftIO $ atomicModifyIORef nc_var upd_fn
+  r' <- liftIO $ readIORef nc_var
+  _  <- liftIO $ evaluate r'
+  return r
+
+-- cut-and-pasted from IfaceEnv, where it lives in the TcRn monad rather than CoreM
+lookupOrigCoreM :: Module -> OccName -> CoreM Name
+lookupOrigCoreM mod occ
+  = do         { mod `seq` occ `seq` return () 
+        ; updNameCache' $ \name_cache ->
+            case lookupOrigNameCache (nsNames name_cache) mod occ of {
+             Just name -> (name_cache, name);
+             Nothing   ->
+              case takeUniqFromSupply (nsUniqs name_cache) of {
+              (uniq, us) ->
+                  let
+                    name      = mkExternalName uniq mod occ noSrcSpan
+                    new_cache = extendNameCache (nsNames name_cache) mod occ name
+                  in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
+    }}}
+\end{code}
\ No newline at end of file