-- ** 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 ()

 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 ()

 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.")

 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.

   | 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

 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,

     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" }

     }