Encode shape information in `PmOracle`
[ghc.git] / compiler / simplCore / CoreMonad.hs
index a9be6c1..d2918a2 100644 (file)
@@ -5,6 +5,7 @@
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module CoreMonad (
     -- * Configuration of the core-to-core passes
@@ -14,7 +15,7 @@ module CoreMonad (
     pprPassDetails,
 
     -- * Plugins
-    PluginPass, bindsOnlyPass,
+    CorePluginPass, bindsOnlyPass,
 
     -- * Counting
     SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
@@ -35,10 +36,6 @@ module CoreMonad (
 
     -- ** Lifting into the monad
     liftIO, liftIOWithCount,
-    liftIO1, liftIO2, liftIO3, liftIO4,
-
-    -- ** Global initialization
-    reinitializeGlobals,
 
     -- ** Dealing with annotations
     getAnnotations, getFirstAnnotations,
@@ -47,17 +44,11 @@ module CoreMonad (
     putMsg, putMsgS, errorMsg, errorMsgS, warnMsg,
     fatalErrorMsg, fatalErrorMsgS,
     debugTraceMsg, debugTraceMsgS,
-    dumpIfSet_dyn,
-
-    -- * Getting 'Name's
-    thNameToGhcName
+    dumpIfSet_dyn
   ) where
 
 import GhcPrelude hiding ( read )
 
-import Convert
-import RdrName
-import Name
 import CoreSyn
 import HscTypes
 import Module
@@ -67,7 +58,6 @@ import Annotations
 
 import IOEnv hiding     ( liftIO, failM, failWithM )
 import qualified IOEnv  ( liftIO )
-import TcEnv            ( lookupGlobal )
 import Var
 import Outputable
 import FastString
@@ -82,15 +72,13 @@ import Data.List
 import Data.Ord
 import Data.Dynamic
 import Data.IORef
-import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Map.Strict as MapStrict
 import Data.Word
 import Control.Monad
 import Control.Applicative ( Alternative(..) )
-
-import qualified Language.Haskell.TH as TH
+import Panic (throwGhcException, GhcException(..))
 
 {-
 ************************************************************************
@@ -108,7 +96,7 @@ data CoreToDo           -- These are diff core-to-core passes,
   = CoreDoSimplify      -- The core-to-core simplifier.
         Int                    -- Max iterations
         SimplMode
-  | CoreDoPluginPass String PluginPass
+  | CoreDoPluginPass String CorePluginPass
   | CoreDoFloatInwards
   | CoreDoFloatOutwards FloatOutSwitches
   | CoreLiberateCase
@@ -123,7 +111,6 @@ data CoreToDo           -- These are diff core-to-core passes,
   | CoreCSE
   | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules
                                            -- matching this string
-  | CoreDoVectorisation
   | CoreDoNothing                -- Useful when building up
   | CoreDoPasses [CoreToDo]      -- lists of these things
 
@@ -149,7 +136,6 @@ instance Outputable CoreToDo where
   ppr CoreDoSpecialising       = text "Specialise"
   ppr CoreDoSpecConstr         = text "SpecConstr"
   ppr CoreCSE                  = text "Common sub-expression"
-  ppr CoreDoVectorisation      = text "Vectorisation"
   ppr CoreDesugar              = text "Desugar (before optimization)"
   ppr CoreDesugarOpt           = text "Desugar (after optimization)"
   ppr CoreTidy                 = text "Tidy Core"
@@ -239,7 +225,7 @@ runMaybe Nothing  _ = CoreDoNothing
 -}
 
 -- | A description of the plugin pass itself
-type PluginPass = ModGuts -> CoreM ModGuts
+type CorePluginPass = ModGuts -> CoreM ModGuts
 
 bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts
 bindsOnlyPass pass guts
@@ -329,7 +315,13 @@ plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
              | otherwise       = sc2
 
 plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
-plusSimplCount _                  _                  = panic "plusSimplCount"
+plusSimplCount lhs                rhs                =
+  throwGhcException . PprProgramError "plusSimplCount" $ vcat
+    [ text "lhs"
+    , pprSimplCount lhs
+    , text "rhs"
+    , pprSimplCount rhs
+    ]
        -- We use one or the other consistently
 
 pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n
@@ -345,6 +337,79 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
           else Outputable.empty
     ]
 
+{- Note [Which transformations are innocuous]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At one point (Jun 18) I wondered if some transformations (ticks)
+might be  "innocuous", in the sense that they do not unlock a later
+transformation that does not occur in the same pass.  If so, we could
+refrain from bumping the overall tick-count for such innocuous
+transformations, and perhaps terminate the simplifier one pass
+earlier.
+
+BUt alas I found that virtually nothing was innocuous!  This Note
+just records what I learned, in case anyone wants to try again.
+
+These transformations are not innocuous:
+
+*** NB: I think these ones could be made innocuous
+          EtaExpansion
+          LetFloatFromLet
+
+LetFloatFromLet
+    x = K (let z = e2 in Just z)
+  prepareRhs transforms to
+    x2 = let z=e2 in Just z
+    x  = K xs
+  And now more let-floating can happen in the
+  next pass, on x2
+
+PreInlineUnconditionally
+  Example in spectral/cichelli/Auxil
+     hinsert = ...let lo = e in
+                  let j = ...lo... in
+                  case x of
+                    False -> ()
+                    True -> case lo of I# lo' ->
+                              ...j...
+  When we PreInlineUnconditionally j, lo's occ-info changes to once,
+  so it can be PreInlineUnconditionally in the next pass, and a
+  cascade of further things can happen.
+
+PostInlineUnconditionally
+  let x = e in
+  let y = ...x.. in
+  case .. of { A -> ...x...y...
+               B -> ...x...y... }
+  Current postinlineUnconditinaly will inline y, and then x; sigh.
+
+  But PostInlineUnconditionally might also unlock subsequent
+  transformations for the same reason as PreInlineUnconditionally,
+  so it's probably not innocuous anyway.
+
+KnownBranch, BetaReduction:
+  May drop chunks of code, and thereby enable PreInlineUnconditionally
+  for some let-binding which now occurs once
+
+EtaExpansion:
+  Example in imaginary/digits-of-e1
+    fail = \void. e          where e :: IO ()
+  --> etaExpandRhs
+    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())
+  --> Next iteration of simplify
+    fail1 = \void. \s. (e |> g) s
+    fail = fail1 |> Void#->sym g
+  And now inline 'fail'
+
+CaseMerge:
+  case x of y {
+    DEFAULT -> case y of z { pi -> ei }
+    alts2 }
+  ---> CaseMerge
+    case x of { pi -> let z = y in ei
+              ; alts2 }
+  The "let z=y" case-binder-swap gets dealt with in the next pass
+-}
+
 pprTickCounts :: Map Tick Int -> SDoc
 pprTickCounts counts
   = vcat (map pprTickGroup groups)
@@ -362,7 +427,7 @@ pprTickGroup group@((tick1,_):_)
                | (tick,n) <- sortBy (flip (comparing snd)) group])
 pprTickGroup [] = panic "pprTickGroup"
 
-data Tick
+data Tick  -- See Note [Which transformations are innocuous]
   = PreInlineUnconditionally    Id
   | PostInlineUnconditionally   Id
 
@@ -383,7 +448,6 @@ data Tick
   | CaseIdentity                Id      -- Case binder
   | FillInCaseDefault           Id      -- Case binder
 
-  | BottomFound
   | SimplifierDone              -- Ticked at each iteration of the simplifier
 
 instance Outputable Tick where
@@ -412,7 +476,6 @@ tickToTag (CaseMerge _)                 = 10
 tickToTag (CaseElim _)                  = 11
 tickToTag (CaseIdentity _)              = 12
 tickToTag (FillInCaseDefault _)         = 13
-tickToTag BottomFound                   = 14
 tickToTag SimplifierDone                = 16
 tickToTag (AltMerge _)                  = 17
 
@@ -432,7 +495,6 @@ tickString (AltMerge _)                 = "AltMerge"
 tickString (CaseElim _)                 = "CaseElim"
 tickString (CaseIdentity _)             = "CaseIdentity"
 tickString (FillInCaseDefault _)        = "FillInCaseDefault"
-tickString BottomFound                  = "BottomFound"
 tickString SimplifierDone               = "SimplifierDone"
 
 pprTickCts :: Tick -> SDoc
@@ -500,7 +562,7 @@ data CoreReader = CoreReader {
 
 -- Note: CoreWriter used to be defined with data, rather than newtype.  If it
 -- is defined that way again, the cw_simpl_count field, at least, must be
--- strict to avoid a space leak (Trac #7702).
+-- strict to avoid a space leak (#7702).
 newtype CoreWriter = CoreWriter {
         cw_simpl_count :: SimplCount
 }
@@ -520,9 +582,7 @@ type CoreIOEnv = IOEnv CoreReader
 -- | The monad used by Core-to-Core passes to access common state, register simplification
 -- statistics and so on
 newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) }
-
-instance Functor CoreM where
-    fmap = liftM
+    deriving (Functor)
 
 instance Monad CoreM where
     mx >>= f = CoreM $ \s -> do
@@ -531,7 +591,7 @@ instance Monad CoreM where
             let w = w1 `plusWriter` w2
             return $ seq w (y, s'', w)
             -- forcing w before building the tuple avoids a space leak
-            -- (Trac #7702)
+            -- (#7702)
 
 instance Applicative CoreM where
     pure x = CoreM $ \s -> nop s x
@@ -669,10 +729,6 @@ getPackageFamInstEnv = do
     eps <- liftIO $ hscEPS hsc_env
     return $ eps_fam_inst_env eps
 
-{-# DEPRECATED reinitializeGlobals "It is not necessary to call reinitializeGlobals. Since GHC 8.2, this function is a no-op and will be removed in GHC 8.4" #-}
-reinitializeGlobals :: CoreM ()
-reinitializeGlobals = return ()
-
 {-
 ************************************************************************
 *                                                                      *
@@ -727,8 +783,8 @@ we aren't using annotations heavily.
 ************************************************************************
 -}
 
-msg :: Severity -> SDoc -> CoreM ()
-msg sev doc
+msg :: Severity -> WarnReason -> SDoc -> CoreM ()
+msg sev reason doc
   = do { dflags <- getDynFlags
        ; loc    <- getSrcSpanM
        ; unqual <- getPrintUnqualified
@@ -740,7 +796,7 @@ msg sev doc
              err_sty  = mkErrStyle dflags unqual
              user_sty = mkUserStyle dflags unqual AllTheWay
              dump_sty = mkDumpStyle dflags unqual
-       ; liftIO $ putLogMsg dflags NoReason sev loc sty doc }
+       ; liftIO $ putLogMsg dflags reason sev loc sty doc }
 
 -- | Output a String message to the screen
 putMsgS :: String -> CoreM ()
@@ -748,7 +804,7 @@ putMsgS = putMsg . text
 
 -- | Output a message to the screen
 putMsg :: SDoc -> CoreM ()
-putMsg = msg SevInfo
+putMsg = msg SevInfo NoReason
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsgS :: String -> CoreM ()
@@ -756,9 +812,9 @@ errorMsgS = errorMsg . text
 
 -- | Output an error to the screen. Does not cause the compiler to die.
 errorMsg :: SDoc -> CoreM ()
-errorMsg = msg SevError
+errorMsg = msg SevError NoReason
 
-warnMsg :: SDoc -> CoreM ()
+warnMsg :: WarnReason -> SDoc -> CoreM ()
 warnMsg = msg SevWarning
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
@@ -767,7 +823,7 @@ fatalErrorMsgS = fatalErrorMsg . text
 
 -- | Output a fatal error to the screen. Does not cause the compiler to die.
 fatalErrorMsg :: SDoc -> CoreM ()
-fatalErrorMsg = msg SevFatal
+fatalErrorMsg = msg SevFatal NoReason
 
 -- | Output a string debugging message at verbosity level of @-v@ or higher
 debugTraceMsgS :: String -> CoreM ()
@@ -775,7 +831,7 @@ debugTraceMsgS = debugTraceMsg . text
 
 -- | Outputs a debugging message at verbosity level of @-v@ or higher
 debugTraceMsg :: SDoc -> CoreM ()
-debugTraceMsg = msg SevDump
+debugTraceMsg = msg SevDump NoReason
 
 -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher
 dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM ()
@@ -784,45 +840,3 @@ dumpIfSet_dyn flag str doc
        ; unqual <- getPrintUnqualified
        ; when (dopt flag dflags) $ liftIO $
          Err.dumpSDoc dflags unqual flag str doc }
-
-{-
-************************************************************************
-*                                                                      *
-               Finding TyThings
-*                                                                      *
-************************************************************************
--}
-
-instance MonadThings CoreM where
-    lookupThing name = do { hsc_env <- getHscEnv
-                          ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-*                                                                      *
-               Template Haskell interoperability
-*                                                                      *
-************************************************************************
--}
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name
-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
-          -- Pick the first that works
-          -- E.g. reify (mkName "A") will pick the class A in preference
-          -- to the data constructor A
-        ; return (listToMaybe names) }
-  where
-    lookup rdr_name
-      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-      = return $ if isExternalName n then Just n else Nothing
-      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-      = do { cache <- getOrigNameCache
-           ; return $ lookupOrigNameCache cache rdr_mod rdr_occ }
-      | otherwise = return Nothing