Open telemwip/open-telemetry

12 files changed, 80 insertions, 30 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index b78883c42e..02af8f0e02 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -378,6 +378,7 @@ import Data.IORef
 import System.FilePath
 import Control.Concurrent
 import Control.Applicative ((<|>))
+import Control.Monad.Catch (MonadMask)
 
 import Maybes
 import System.IO.Error  ( isDoesNotExistError )
@@ -1068,15 +1069,15 @@ instance Outputable CoreModule where
 -- desugars the module, then returns the resulting Core module (consisting of
 -- the module name, type declarations, and function declarations) if
 -- successful.
-compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreModule :: (GhcMonad m, MonadMask m) => FilePath -> m CoreModule
 compileToCoreModule = compileCore False
 
 -- | Like compileToCoreModule, but invokes the simplifier, so
 -- as to return simplified and tidied Core.
-compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreSimplified :: (MonadMask m, GhcMonad m) => FilePath -> m CoreModule
 compileToCoreSimplified = compileCore True
 
-compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
+compileCore :: (GhcMonad m, MonadMask m) => Bool -> FilePath -> m CoreModule
 compileCore simplify fn = do
    -- First, set the target to the desired filename
    target <- guessTarget fn Nothing
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs
index 81faa53e47..8a438cb4b0 100644
--- a/compiler/GHC/Core/Opt/Monad.hs
+++ b/compiler/GHC/Core/Opt/Monad.hs
@@ -5,6 +5,7 @@
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DerivingVia #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -79,7 +80,11 @@ import Data.Word
 import Control.Monad
 import Control.Applicative ( Alternative(..) )
 import Panic (throwGhcException, GhcException(..))
-
+import Control.Monad.Catch
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Writer
+import IOEnv (IOEnv(IOEnv))
+import Data.Semigroup ((<>))
 {-
 ************************************************************************
 *                                                                      *
@@ -127,7 +132,7 @@ instance Outputable CoreToDo where
   ppr (CoreDoSimplify _ _)     = text "Simplifier"
   ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s
   ppr CoreDoFloatInwards       = text "Float inwards"
-  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)
+  ppr (CoreDoFloatOutwards f)  = text "Float out" Outputable.<> parens (ppr f)
   ppr CoreLiberateCase         = text "Liberate case"
   ppr CoreDoStaticArgs         = text "Static argument"
   ppr CoreDoCallArity          = text "Called arity analysis"
@@ -171,10 +176,10 @@ instance Outputable SimplMode where
                    , sm_eta_expand = eta, sm_case_case = cc })
        = text "SimplMode" <+> braces (
          sep [ text "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
+               brackets (text (concat $ intersperse "," ss)) Outputable.<> comma
+             , pp_flag i   (sLit "inline") Outputable.<> comma
+             , pp_flag r   (sLit "rules") Outputable.<> comma
+             , pp_flag eta (sLit "eta-expand") Outputable.<> comma
              , pp_flag cc  (sLit "case-of-case") ])
          where
            pp_flag f s = ppUnless f (text "no") <+> ptext s
@@ -576,12 +581,21 @@ plusWriter w1 w2 = CoreWriter {
         cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)
     }
 
+instance Monoid CoreWriter where
+  mempty = emptyWriter unsafeGlobalDynFlags
+
+instance Semigroup CoreWriter where
+  (<>) = plusWriter
+
 type CoreIOEnv = IOEnv CoreReader
 
 -- | The monad used by Core-to-Core passes to register simplification statistics.
 --  Also used to have common state (in the form of UniqueSupply) for generating Uniques.
 newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }
     deriving (Functor)
+    deriving MonadCatch via (WriterT CoreWriter (ReaderT CoreReader IO))
+    deriving MonadThrow via (WriterT CoreWriter (ReaderT CoreReader IO))
+    deriving MonadMask via (WriterT CoreWriter (ReaderT CoreReader IO))
 
 instance Monad CoreM where
     mx >>= f = CoreM $ do
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 7df02dd7c8..dfab350f22 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -37,6 +37,7 @@ import GhcPrelude
 
 import qualified GHC.Runtime.Linker as Linker
 
+import Control.Monad.Catch (MonadMask)
 import GHC.Driver.Phases
 import GHC.Driver.Pipeline
 import GHC.Driver.Session
@@ -120,7 +121,7 @@ label_self thread_name = do
 -- again.
 -- In case of errors, just throw them.
 --
-depanal :: GhcMonad m =>
+depanal :: (GhcMonad m, MonadMask m) =>
            [ModuleName]  -- ^ excluded modules
         -> Bool          -- ^ allow duplicate roots
         -> m ModuleGraph
@@ -132,7 +133,7 @@ depanal excluded_mods allow_dup_roots = do
 
 -- | Perform dependency analysis like in 'depanal'.
 -- In case of errors, the errors and an empty module graph are returned.
-depanalE :: GhcMonad m =>     -- New for #17459
+depanalE :: (GhcMonad m, MonadMask m) =>     -- New for #17459
             [ModuleName]      -- ^ excluded modules
             -> Bool           -- ^ allow duplicate roots
             -> m (ErrorMessages, ModuleGraph)
@@ -161,7 +162,7 @@ depanalE excluded_mods allow_dup_roots = do
 -- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
 -- new module graph.
 depanalPartial
-    :: GhcMonad m
+    :: (GhcMonad m, MonadMask m)
     => [ModuleName]  -- ^ excluded modules
     -> Bool          -- ^ allow duplicate roots
     -> m (ErrorMessages, ModuleGraph)
@@ -284,7 +285,7 @@ data LoadHowMuch
 -- After processing this empty ModuleGraph, the errors of depanalE are thrown.
 -- All other errors are reported using the 'defaultWarnErrLogger'.
 --
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+load :: (GhcMonad m, MonadMask m) => LoadHowMuch -> m SuccessFlag
 load how_much = do
     (errs, mod_graph) <- depanalE [] False                        -- #17459
     success <- load' how_much (Just batchMsg) mod_graph
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index d45b39e3b3..20fc72ec02 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -44,6 +44,7 @@ import System.IO.Error  ( isEOFError )
 import Control.Monad    ( when )
 import Data.Maybe       ( isJust )
 import Data.IORef
+import Control.Monad.Catch
 import qualified Data.Set as Set
 
 -----------------------------------------------------------------
@@ -52,7 +53,7 @@ import qualified Data.Set as Set
 --
 -----------------------------------------------------------------
 
-doMkDependHS :: GhcMonad m => [FilePath] -> m ()
+doMkDependHS :: (MonadMask m ,GhcMonad m) => [FilePath] -> m ()
 doMkDependHS srcs = do
     -- Initialisation
     dflags0 <- GHC.getSessionDynFlags
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 3825757ac6..8e09320cda 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveFunctor, RankNTypes #-}
+{-# LANGUAGE CPP, DeriveFunctor, RankNTypes, DerivingVia #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 -- -----------------------------------------------------------------------------
 --
@@ -30,6 +30,8 @@ import GHC.Driver.Types
 import GHC.Driver.Session
 import Exception
 import ErrUtils
+import Control.Monad.Catch(MonadMask, MonadCatch, MonadThrow)
+import Control.Monad.Trans.Reader
 
 import Control.Monad
 import Data.IORef
@@ -91,6 +93,9 @@ logWarnings warns = do
 -- e.g., to maintain additional state consider wrapping this monad or using
 -- 'GhcT'.
 newtype Ghc a = Ghc { unGhc :: Session -> IO a } deriving (Functor)
+    deriving MonadCatch via (ReaderT Session IO)
+    deriving MonadThrow via (ReaderT Session IO)
+    deriving MonadMask via (ReaderT Session IO)
 
 -- | The Session is a handle to the complete state of a compilation
 -- session.  A compilation session consists of a set of modules
diff --git a/compiler/GHC/Driver/Types.hs b/compiler/GHC/Driver/Types.hs
index 581a90ea1d..4f6bb26738 100644
--- a/compiler/GHC/Driver/Types.hs
+++ b/compiler/GHC/Driver/Types.hs
@@ -14,6 +14,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
 
 -- | Types for the per-module compiler
 module GHC.Driver.Types (
@@ -231,6 +232,8 @@ import Exception
 import System.FilePath
 import Control.DeepSeq
 import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State (StateT(StateT))
+import Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow)
 import Control.Monad.Trans.Class
 
 -- -----------------------------------------------------------------------------
@@ -275,6 +278,9 @@ data HscStatus
 
 newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
     deriving (Functor)
+    deriving MonadCatch via (ReaderT HscEnv (StateT WarningMessages IO))
+    deriving MonadThrow via (ReaderT HscEnv (StateT WarningMessages IO))
+    deriving MonadMask via (ReaderT HscEnv (StateT WarningMessages IO))
 
 instance Applicative Hsc where
     pure a = Hsc $ \_ w -> return (a, w)
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index c1c4b6dc24..f33a98358f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -65,6 +65,7 @@ Library
                    process    >= 1   && < 1.7,
                    bytestring >= 0.9 && < 0.11,
                    binary     == 0.8.*,
+                   exceptions,
                    time       >= 1.4 && < 1.10,
                    containers >= 0.5 && < 0.7,
                    array      >= 0.1 && < 0.6,
@@ -168,6 +169,7 @@ Library
         NoImplicitPrelude
 
     Exposed-Modules:
+        OpenTelemetry
         GHC.Iface.Ext.Types
         GHC.Iface.Ext.Debug
         GHC.Iface.Ext.Binary
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index 0096891e54..8771a9c392 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -66,6 +66,7 @@ module ErrUtils (
 
 import GhcPrelude
 
+import Control.Monad.Catch (MonadMask)
 import Bag
 import Exception
 import Outputable
@@ -93,6 +94,7 @@ import System.IO
 import System.IO.Error  ( catchIOError )
 import GHC.Conc         ( getAllocationCounter )
 import System.CPUTime
+import OpenTelemetry
 
 -------------------------
 type MsgDoc  = SDoc
@@ -661,7 +663,7 @@ data PrintTimings = PrintTimings | DontPrintTimings
 -- requested, the result is only forced when timings are enabled.
 --
 -- See Note [withTiming] for more.
-withTiming :: MonadIO m
+withTiming :: (MonadIO m, MonadMask m)
            => DynFlags     -- ^ DynFlags
            -> SDoc         -- ^ The name of the phase
            -> (a -> ())    -- ^ A function to force the result
@@ -672,7 +674,7 @@ withTiming dflags what force action =
   withTiming' dflags what force PrintTimings action
 
 -- | Like withTiming but get DynFlags from the Monad.
-withTimingD :: (MonadIO m, HasDynFlags m)
+withTimingD :: (MonadIO m, HasDynFlags m, MonadMask m)
            => SDoc         -- ^ The name of the phase
            -> (a -> ())    -- ^ A function to force the result
                            -- (often either @const ()@ or 'rnf')
@@ -688,7 +690,7 @@ withTimingD what force action = do
 --
 --   See Note [withTiming] for more.
 withTimingSilent
-  :: MonadIO m
+  :: (MonadIO m, MonadMask m)
   => DynFlags   -- ^ DynFlags
   -> SDoc       -- ^ The name of the phase
   -> (a -> ())  -- ^ A function to force the result
@@ -704,7 +706,7 @@ withTimingSilent dflags what force action =
 --
 --   See Note [withTiming] for more.
 withTimingSilentD
-  :: (MonadIO m, HasDynFlags m)
+  :: (MonadIO m, HasDynFlags m, MonadMask m)
   => SDoc       -- ^ The name of the phase
   -> (a -> ())  -- ^ A function to force the result
                 -- (often either @const ()@ or 'rnf')
@@ -715,7 +717,7 @@ withTimingSilentD what force action = do
   withTiming' dflags what force DontPrintTimings action
 
 -- | Worker for 'withTiming' and 'withTimingSilent'.
-withTiming' :: MonadIO m
+withTiming' :: (MonadIO m, MonadMask m)
             => DynFlags   -- ^ A means of getting a 'DynFlags' (often
                             -- 'getDynFlags' will work here)
             -> SDoc         -- ^ The name of the phase
@@ -729,12 +731,14 @@ withTiming' dflags what force_result prtimings action
           then do whenPrintTimings $
                     logInfo dflags (defaultUserStyle dflags) $
                       text "***" <+> what <> colon
-                  eventBegins dflags what
-                  alloc0 <- liftIO getAllocationCounter
-                  start <- liftIO getCPUTime
-                  !r <- action
-                  () <- pure $ force_result r
-                  eventEnds dflags what
+                  (alloc0, start, r) <- telem $ do
+                    eventBegins dflags what
+                    alloc0 <- liftIO getAllocationCounter
+                    start <- liftIO getCPUTime
+                    !r <- action
+                    () <- pure $ force_result r
+                    eventEnds dflags what
+                    return (alloc0, start, r)
                   end <- liftIO getCPUTime
                   alloc1 <- liftIO getAllocationCounter
                   -- recall that allocation counter counts down
@@ -762,6 +766,7 @@ withTiming' dflags what force_result prtimings action
            else action
 
     where whenPrintTimings = liftIO . when (prtimings == PrintTimings)
+          telem = withSpan (showSDocOneLine dflags what)
           eventBegins dflags w = do
             whenPrintTimings $ traceMarkerIO (eventBeginsDoc dflags w)
             liftIO $ traceEventIO (eventBeginsDoc dflags w)
diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index f9da146da5..d9de83d756 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DerivingVia #-}
 --
 -- (c) The University of Glasgow 2002-2006
 --
@@ -11,7 +12,7 @@
 --
 
 module IOEnv (
-        IOEnv, -- Instance of Monad
+        IOEnv(..), -- Instance of Monad
 
         -- Monad utilities
         module MonadUtils,
@@ -45,13 +46,19 @@ import System.IO        ( fixIO )
 import Control.Monad
 import MonadUtils
 import Control.Applicative (Alternative(..))
+import Control.Monad.Trans.Reader
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 
 ----------------------------------------------------------------------
 -- Defining the monad type
 ----------------------------------------------------------------------
 
 
-newtype IOEnv env a = IOEnv (env -> IO a) deriving (Functor)
+newtype IOEnv env a = IOEnv (env -> IO a)
+  deriving (Functor)
+  deriving MonadCatch via (ReaderT env IO)
+  deriving MonadThrow via (ReaderT env IO)
+  deriving MonadMask via (ReaderT env IO)
 
 unIOEnv :: IOEnv env a -> (env -> IO a)
 unIOEnv (IOEnv m) = m
@@ -101,6 +108,9 @@ instance ExceptionMonad (IOEnv a) where
                              in
                                 unIOEnv (f g_restore) s
 
+
+
+
 instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
     getDynFlags = do env <- getEnv
                      return $! extractDynFlags env
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 27e31b6cf6..04da5e0c57 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -35,6 +35,7 @@ module GHCi.UI.Monad (
 
 #include "HsVersions.h"
 
+import Control.Monad.Catch (MonadMask)
 import GHCi.UI.Info (ModInfo)
 import qualified GHC
 import GHC.Driver.Monad hiding (liftIO)
@@ -273,7 +274,7 @@ instance Applicative GHCi where
 instance Monad GHCi where
   (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
 
-class GhcMonad m => GhciMonad m where
+class (MonadMask m, GhcMonad m) => GhciMonad m where
   getGHCiState    :: m GHCiState
   setGHCiState    :: GHCiState -> m ()
   modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
@@ -320,6 +321,7 @@ instance ExceptionMonad GHCi where
                              in
                                 unGHCi (f g_restore) s
 
+{-
 instance MonadThrow Ghc where
   throwM = liftIO . throwM
 
@@ -340,6 +342,7 @@ instance MonadMask Ghc where
       (unGhc acquire s)
       (\resource exitCase -> unGhc (release resource exitCase) s)
       (\resource -> unGhc (use resource) s)
+      -}
 
 instance MonadThrow GHCi where
   throwM = liftIO . throwM
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 7a356b920a..2a441bfb22 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -63,6 +63,7 @@ import Util
 import Panic
 import GHC.Types.Unique.Supply
 import MonadUtils       ( liftIO )
+import OpenTelemetry
 
 -- Imports for --abi-hash
 import GHC.Iface.Load      ( loadUserInterface )
@@ -98,7 +99,7 @@ import Prelude
 -- GHC's command-line interface
 
 main :: IO ()
-main = do
+main = withSpan "main" $ do
    initGCStatistics -- See Note [-Bsymbolic and hooks]
    hSetBuffering stdout LineBuffering
    hSetBuffering stderr LineBuffering
diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs
index 5828c3d5f9..e8be75f4d3 100644
--- a/hadrian/src/Settings/Default.hs
+++ b/hadrian/src/Settings/Default.hs
@@ -76,6 +76,7 @@ stage0Packages = do
              , text
              , transformers
              , unlit
+             , exceptions
              ]
           ++ [ terminfo | not windowsHost, not cross ]
           ++ [ timeout  | windowsHost                ]