-- ** Debug output

     EndPassConfig (..),

     endPassIO,

     displayLintResults, dumpPassResult

  ) where

 impactful. Changing `lint_app` reduced allocations for one test program I was

 looking at by ~4%.

 ************************************************************************

 *                                                                      *

                  Beginning and ending passes

 ************************************************************************

 -}

 -- | Configuration for boilerplate operations at the end of a

 -- compilation pass producing Core.

 data EndPassConfig = EndPassConfig

                    -> IO ()

 displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)

   | not (isEmptyBag errs)

            (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs

                  , text "*** Offending Program ***"

                  , pp_pgm

   | not (isEmptyBag warns)

   , log_enable_debug (logFlags logger)

   , display_warnings

         (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))

   | otherwise = return ()

 ************************************************************************

 -}

     logger <- getLogger

     name_ppr_ctx <- getNamePprCtx

 -- | Output a String message to the screen

 putMsgS :: String -> CoreM ()

 -- | Output a message to the screen

 putMsg :: SDoc -> CoreM ()

 diagnostic :: DiagnosticReason -> SDoc -> CoreM ()

 diagnostic reason doc = do

 -- | Output a fatal error to the screen. Does not cause the compiler to die.

 fatalErrorMsg :: SDoc -> CoreM ()

 -- | Output a string debugging message at verbosity level of @-v@ or higher

 debugTraceMsgS :: String -> CoreM ()

 -- | Outputs a debugging message at verbosity level of @-v@ or higher

 debugTraceMsg :: SDoc -> CoreM ()

 import GHC.Platform

 import GHC.ForeignSrcLang

 import GHC.Data.FastString

 import GHC.CmmToAsm     ( nativeCodeGen )

 import GHC.CmmToLlvm    ( llvmCodeGen )

 import GHC.Unit

 import GHC.Unit.Finder      ( mkStubPaths )

 import GHC.Types.CostCentre

 import GHC.Types.ForeignStubs

 import GHC.Types.Unique.DSM

                   (text "CmmLint"<+>brackets (ppr this_mod))

                   (const ()) $ do

                 { case cmmLint (targetPlatform dflags) cmm of

                                        ; ghcExit logger 1

                                        }

                         Nothing  -> return ()

     sortMessages = sortMsgBag (Just opts) . getMessages

 printMessage :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> MsgEnvelope a -> IO ()

   where

     logflags :: LogFlags

     logflags = logFlags logger

     doc :: SDoc

     doc = updSDocContext (\_ -> ctx) (messageWithHints diagnostic)

     style :: PprStyle

     style = mkErrStyle (errMsgContext message)

     severity :: Severity

     severity = errMsgSeverity message

     messageWithHints :: a -> SDoc

     messageWithHints e =

       let main_msg = formatBulleted $ diagnosticMessage msg_opts e

                hs  -> main_msg $$ hang (text "Suggested fixes:") 2

                                        (formatBulleted  $ mkDecorated . map ppr $ hs)

 -- | Given a bag of diagnostics, turn them into an exception if

 -- any has 'SevError', or print them out otherwise.

    | Opt_D_dump_view_pattern_commoning

    | Opt_D_verbose_core2core

    | Opt_D_dump_debug

    | Opt_D_ppr_debug

    | Opt_D_no_debug_output

    | Opt_D_dump_faststrings

                          ]

     badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer

     badFlag df (ext,loc,on,_)

                             text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"]

         | otherwise = []

     badInsts insts = concatMap badInst insts

     checkOverlap _             = True

     badInst ins | checkOverlap (overlapMode (is_flag ins))

                       ppr (overlapMode $ is_flag ins) <+>

                 | otherwise = []

 -- | Figure out the final correct safe haskell mode

     fatals <- liftIO $ newIORef []

     logger <- getLogger

               -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())

               -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())

               -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())

             _ -> action

         modifyLogger,

         pushLogHookM,

         popLogHookM,

         putLogMsgM,

         putMsgM,

         withTimingM,

 import GHC.Utils.Error

 import GHC.Utils.Logger

 import GHC.Types.SourceError

 import Control.Monad

 popLogHookM :: GhcMonad m => m ()

 popLogHookM  = modifyLogger popLogHook

 -- | Put a log message

 putMsgM :: GhcMonad m => SDoc -> m ()

 putMsgM doc = do

     liftIO $ putMsg logger doc

 -- | Put a log message

     logger <- getLogger

 -- | Time an action

 withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b

 linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()

 linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do

   when (haveRtsOptsFlags dflags) $

       $ withPprStyle defaultUserStyle

       (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$

       text "    Call hs_init_ghc() from your main() function to set these options.")

 import Control.Concurrent

 import Data.IORef

 import GHC.Types.Error

 import GHC.Utils.Logger

 import qualified Data.IntMap as IM

 import Control.Concurrent.STM

 -- to. A 'Nothing' value contains the result of compilation, and denotes the

 -- end of the message queue.

 data LogQueue = LogQueue { logQueueId :: !Int

                          , logQueueSemaphore :: !(MVar ())

                          }

   writeLogQueueInternal lq Nothing

 writeLogQueue lq msg = do

   writeLogQueueInternal lq (Just msg)

 -- | Internal helper for writing log messages

 writeLogQueueInternal (LogQueue _n ref sem) msg = do

     atomicModifyIORef' ref $ \msgs -> (msg:msgs,())

     _ <- tryPutMVar sem ()

 -- The log_action callback that is used to synchronize messages from a

 -- worker thread.

 parLogAction :: LogQueue -> LogAction

 -- Print each message from the log_queue using the global logger

 printLogs :: Logger -> LogQueue -> IO ()

         print_loop [] = read_msgs

         print_loop (x:xs) = case x of

                 print_loop xs

             -- Exit the loop once we encounter the end marker.

             Nothing -> return ()

         (NoArg (setGeneralFlag Opt_NoTypeableBinds))

   , make_ord_flag defGhcFlag "ddump-debug"

         (setDumpFlag Opt_D_dump_debug)

   , make_ord_flag defGhcFlag "dppr-debug"

         (setDumpFlag Opt_D_ppr_debug)

   , make_ord_flag defGhcFlag "ddebug-output"

 import GHC.Types.SafeHaskell

 import GHC.Types.TypeEnv

 import GHC.Types.Unique.DSet

 import GHC.Types.TyThing

 import GHC.Types.PkgQual

 showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()

 showIface logger dflags unit_state name_cache filename = do

    let profile = targetProfile dflags

    -- skip the hi way check; we don't want to worry about profiled vs.

    -- non-profiled interfaces, for example.

                                    neverQualifyModules

                                    neverQualifyPackages

                                    alwaysPrintPromTick

       $ withPprStyle (mkDumpStyle name_ppr_ctx)

       $ pprModIface unit_state iface

 import GHC.Types.SrcLoc

 import GHC.Types.Unique.DSet

 import GHC.Types.Unique.DFM

 import GHC.Utils.Outputable

 import GHC.Utils.Panic

 -}

 dieWith :: LinkDepsOpts -> SrcSpan -> SDoc -> IO a

 throwProgramError :: LinkDepsOpts -> SDoc -> IO a

 throwProgramError opts doc = throwGhcExceptionIO (ProgramError (renderWithContext (ldPprOpts opts) doc))

   | isObjectFilename platform f = return (Just (Objects [f]))

   | isDynLibFilename platform f = return (Just (DLLPath f))

   | otherwise          = do

             $ withPprStyle defaultUserStyle

             (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))

         return Nothing

 maybePutSDoc :: Logger -> SDoc -> IO ()

 maybePutSDoc logger s

     = when (logVerbAtLeast logger 2) $

               MCInteractive

               $ withPprStyle defaultUserStyle s

 maybePutStr :: Logger -> String -> IO ()

                 setSession new_env

                 -- this disables logging of errors

                 pushLogHookM (const noop_log)

                 return (hsc_env, bname)

 import GHC.Core.DataCon

 import GHC.Core             ( AltCon(..) )

 import GHC.Core.Type

 import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )

 import GHC.Types.CostCentre ( isCurrentCCS )

       Nothing  ->

         return ()

       Just msg -> do

           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>

                         text whodunit <+> text "***",

                   msg,

   if logHasDumpFlag logger Opt_D_ppr_debug

     then do

       loc <- getSrcSpanM

     else

       return doc

     env <- getLclEnv

     let full_msg = (if_loc env <> colon) $$ nest 2 msg

     logger <- getLogger

     failM

 --------------------

                       logger <- getLogger

                       let msg = hang (text "forkM failed:" <+> doc)

                                    2 (text (show exn))

                 ; traceIf (text "} ending fork (badly)" <+> doc)

                 ; pgmError "Cannot continue after interface file error" }

     }

    -- * Classifying Messages

    , Severity (..)

    , Diagnostic (..)

    , UnknownDiagnostic (..)

    , mapDecoratedSDoc

    , pprMessageBag

    , formatDiagnostic

    , getCaretDiagnostic

 -- | The class for a diagnostic message. The main purpose is to classify a

 -- message within GHC, to distinguish it from a debug/dump message vs a proper

 -- diagnostic, for which we include a 'DiagnosticReason'.

     -- ^ Log message intended for compiler developers

     -- No file\/line\/column stuff

     -- ^ Log messages intended for end users.

     -- No file\/line\/column stuff.

     -- ^ Diagnostics from the compiler. This constructor is very powerful as

     -- arbitrary permutation of 'Severity' and 'DiagnosticReason'. As such,

     -- users are encouraged to use higher level primitives

     -- instead. Use this constructor directly only if you need to construct

     -- should always have a 'DiagnosticCode'. See Note [Diagnostic codes].

 {-# COMPLETE MCOutput, MCFatal, MCInteractive, MCDump, MCInfo, MCDiagnostic #-}

 {-

 Note [Suppressing Messages]

 -- | Used to describe warnings and errors

 --   o With 'SevIgnore' the message is suppressed

 --   o Output is intended for end users

 data Severity

   json SevWarning = JSString "Warning"

   json SevError = JSString "Error"

 instance ToJson DiagnosticCode where

   json c = JSInt (fromIntegral (diagnosticCodeNumber c))

 pprMessageBag :: Bag SDoc -> SDoc

 pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))

       in formatLocMessageWarningGroups locn msg_title empty empty msg

 formatDiagnostic

   :: Bool                               -- ^ Print warning groups?

   -> SrcSpan                            -- ^ location

                    code_doc <+> warning_flag_doc

       in coloured (Col.sMessage col_scheme)

 getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour

 getSeverityColour severity = case severity of

   SevWarning -> Col.sWarning

   SevIgnore -> const mempty

 getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty

   caretDiagnostic <$> getSrcLine (srcSpanFile span) row

   where

     getSrcLine fn i =

     caretDiagnostic Nothing = empty

     caretDiagnostic (Just srcLineWithNewline) =

       sdocOption sdocColScheme$ \col_scheme ->

           marginColour = Col.sMargin col_scheme

       in

       coloured marginColour (text marginSpace) <>

         -- * Messages

         Diagnostic(..),

         MsgEnvelope(..),

         SDoc,

         DecoratedSDoc(unDecorated),

         Messages,

         -- ** Construction

         DiagOpts (..), emptyDiagOpts, diag_wopt, diag_fatal_wopt,

         mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope,

         mkErrorMsgEnvelope,

         mkLintWarning, diagReasonSeverity,

                                , errMsgContext   = name_ppr_ctx

                                , errMsgReason    = reason })

   = withErrStyle name_ppr_ctx $

         (formatBulleted $ diagnosticMessage opts e)

 sortMsgBag :: Maybe DiagOpts -> Bag (MsgEnvelope e) -> [MsgEnvelope e]

 fatalErrorMsg :: Logger -> SDoc -> IO ()

 fatalErrorMsg logger msg =

 compilationProgressMsg :: Logger -> SDoc -> IO ()

 compilationProgressMsg logger msg = do

   = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg)

 logInfo :: Logger -> SDoc -> IO ()

 -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'

 logOutput :: Logger -> SDoc -> IO ()

 prettyPrintGhcErrors :: ExceptionMonad m => Logger -> m a -> m a

     -- * Logger setup

     , initLogger

     , LogAction

     , DumpAction

     , TraceAction

     , DumpFormat (..)

     -- ** Hooks

     , popLogHook

     , pushLogHook

     , popDumpHook

     , pushDumpHook

     , popTraceHook

     , putLogMsg

     , defaultLogAction

     , defaultLogActionWithHandles

     , defaultLogActionHPrintDoc

     , defaultLogActionHPutStrDoc

     , logMsg

     , logDumpMsg

     -- * Dumping

     , defaultDumpAction

     , putDumpFile

 import GHC.Prelude

 import GHC.Driver.Flags

 import GHC.Types.Error

 import qualified GHC.Utils.Ppr as Pretty

 import GHC.Utils.Outputable

 import GHC.Utils.Panic

 import GHC.Data.EnumSet (EnumSet)

 import qualified GHC.Data.EnumSet as EnumSet

 import System.Directory

 import System.FilePath  ( takeDirectory, (</>) )

 ---------------------------------------------------------------