never executed always true always false
1 {-# LANGUAGE RankNTypes #-}
2
3 -- | Logger
4 --
5 -- The Logger is an configurable entity that is used by the compiler to output
6 -- messages on the console (stdout, stderr) and in dump files.
7 --
8 -- The behaviour of default Logger returned by `initLogger` can be modified with
9 -- hooks. The compiler itself uses hooks in multithreaded code (--make) and it
10 -- is also probably used by ghc-api users (IDEs, etc.).
11 --
12 -- In addition to hooks, the Logger suppors LogFlags: basically a subset of the
13 -- command-line flags that control the logger behaviour at a higher level than
14 -- hooks.
15 --
16 -- 1. Hooks are used to define how to generate a info/warning/error/dump messages
17 -- 2. LogFlags are used to decide when and how to generate messages
18 --
19 module GHC.Utils.Logger
20 ( Logger
21 , HasLogger (..)
22 , ContainsLogger (..)
23
24 -- * Logger setup
25 , initLogger
26 , LogAction
27 , DumpAction
28 , TraceAction
29 , DumpFormat (..)
30
31 -- ** Hooks
32 , popLogHook
33 , pushLogHook
34 , popDumpHook
35 , pushDumpHook
36 , popTraceHook
37 , pushTraceHook
38 , makeThreadSafe
39
40 -- ** Flags
41 , LogFlags (..)
42 , defaultLogFlags
43 , log_dopt
44 , log_set_dopt
45 , setLogFlags
46 , updateLogFlags
47 , logFlags
48 , logHasDumpFlag
49 , logVerbAtLeast
50
51 -- * Logging
52 , jsonLogAction
53 , putLogMsg
54 , defaultLogAction
55 , defaultLogActionHPrintDoc
56 , defaultLogActionHPutStrDoc
57 , logMsg
58 , logDumpMsg
59
60 -- * Dumping
61 , defaultDumpAction
62 , putDumpFile
63 , putDumpFileMaybe
64 , putDumpFileMaybe'
65 , withDumpFileHandle
66 , touchDumpFile
67 , logDumpFile
68
69 -- * Tracing
70 , defaultTraceAction
71 , putTraceMsg
72 , loggerTraceFlushUpdate
73 , loggerTraceFlush
74 , logTraceMsg
75 )
76 where
77
78 import GHC.Prelude
79 import GHC.Driver.Flags
80 import GHC.Types.Error
81 import GHC.Types.SrcLoc
82
83 import qualified GHC.Utils.Ppr as Pretty
84 import GHC.Utils.Outputable
85 import GHC.Utils.Json
86 import GHC.Utils.Panic
87
88 import GHC.Data.EnumSet (EnumSet)
89 import qualified GHC.Data.EnumSet as EnumSet
90
91 import Data.IORef
92 import System.Directory
93 import System.FilePath ( takeDirectory, (</>) )
94 import qualified Data.Set as Set
95 import Data.Set (Set)
96 import Data.List (intercalate, stripPrefix)
97 import qualified Data.List.NonEmpty as NE
98 import Data.Time
99 import System.IO
100 import Control.Monad
101 import Control.Concurrent.MVar
102 import System.IO.Unsafe
103 import Debug.Trace (trace)
104
105 ---------------------------------------------------------------
106 -- Log flags
107 ---------------------------------------------------------------
108
109 -- | Logger flags
110 data LogFlags = LogFlags
111 { log_default_user_context :: SDocContext
112 , log_default_dump_context :: SDocContext
113 , log_dump_flags :: !(EnumSet DumpFlag) -- ^ Dump flags
114 , log_show_caret :: !Bool -- ^ Show caret in diagnostics
115 , log_show_warn_groups :: !Bool -- ^ Show warning flag groups
116 , log_enable_timestamps :: !Bool -- ^ Enable timestamps
117 , log_dump_to_file :: !Bool -- ^ Enable dump to file
118 , log_dump_dir :: !(Maybe FilePath) -- ^ Dump directory
119 , log_dump_prefix :: !(Maybe FilePath) -- ^ Normal dump path ("basename.")
120 , log_dump_prefix_override :: !(Maybe FilePath) -- ^ Overriden dump path
121 , log_enable_debug :: !Bool -- ^ Enable debug output
122 , log_verbosity :: !Int -- ^ Verbosity level
123 }
124
125 -- | Default LogFlags
126 defaultLogFlags :: LogFlags
127 defaultLogFlags = LogFlags
128 { log_default_user_context = defaultSDocContext
129 , log_default_dump_context = defaultSDocContext
130 , log_dump_flags = EnumSet.empty
131 , log_show_caret = True
132 , log_show_warn_groups = True
133 , log_enable_timestamps = True
134 , log_dump_to_file = False
135 , log_dump_dir = Nothing
136 , log_dump_prefix = Nothing
137 , log_dump_prefix_override = Nothing
138 , log_enable_debug = False
139 , log_verbosity = 0
140 }
141
142 -- | Test if a DumpFlag is enabled
143 log_dopt :: DumpFlag -> LogFlags -> Bool
144 log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags
145
146 -- | Enable a DumpFlag
147 log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
148 log_set_dopt f logflags = logflags { log_dump_flags = EnumSet.insert f (log_dump_flags logflags) }
149
150 -- | Test if a DumpFlag is set
151 logHasDumpFlag :: Logger -> DumpFlag -> Bool
152 logHasDumpFlag logger f = log_dopt f (logFlags logger)
153
154 -- | Test if verbosity is >= to the given value
155 logVerbAtLeast :: Logger -> Int -> Bool
156 logVerbAtLeast logger v = log_verbosity (logFlags logger) >= v
157
158 -- | Update LogFlags
159 updateLogFlags :: Logger -> (LogFlags -> LogFlags) -> Logger
160 updateLogFlags logger f = setLogFlags logger (f (logFlags logger))
161
162 -- | Set LogFlags
163 setLogFlags :: Logger -> LogFlags -> Logger
164 setLogFlags logger flags = logger { logFlags = flags }
165
166
167 ---------------------------------------------------------------
168 -- Logger
169 ---------------------------------------------------------------
170
171 type LogAction = LogFlags
172 -> MessageClass
173 -> SrcSpan
174 -> SDoc
175 -> IO ()
176
177 type DumpAction = LogFlags
178 -> PprStyle
179 -> DumpFlag
180 -> String
181 -> DumpFormat
182 -> SDoc
183 -> IO ()
184
185 type TraceAction a = LogFlags -> String -> SDoc -> a -> a
186
187 -- | Format of a dump
188 --
189 -- Dump formats are loosely defined: dumps may contain various additional
190 -- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint
191 -- (e.g. for syntax highlighters).
192 data DumpFormat
193 = FormatHaskell -- ^ Haskell
194 | FormatCore -- ^ Core
195 | FormatSTG -- ^ STG
196 | FormatByteCode -- ^ ByteCode
197 | FormatCMM -- ^ Cmm
198 | FormatASM -- ^ Assembly code
199 | FormatC -- ^ C code/header
200 | FormatLLVM -- ^ LLVM bytecode
201 | FormatText -- ^ Unstructured dump
202 deriving (Show,Eq)
203
204 type DumpCache = IORef (Set FilePath)
205
206 data Logger = Logger
207 { log_hook :: [LogAction -> LogAction]
208 -- ^ Log hooks stack
209
210 , dump_hook :: [DumpAction -> DumpAction]
211 -- ^ Dump hooks stack
212
213 , trace_hook :: forall a. [TraceAction a -> TraceAction a]
214 -- ^ Trace hooks stack
215
216 , generated_dumps :: DumpCache
217 -- ^ Already dumped files (to append instead of overwriting them)
218
219 , trace_flush :: IO ()
220 -- ^ Flush the trace buffer
221
222 , logFlags :: !LogFlags
223 -- ^ Logger flags
224 }
225
226 -- | Set the trace flushing function
227 --
228 -- The currently set trace flushing function is passed to the updating function
229 loggerTraceFlushUpdate :: Logger -> (IO () -> IO ()) -> Logger
230 loggerTraceFlushUpdate logger upd = logger { trace_flush = upd (trace_flush logger) }
231
232 -- | Calls the trace flushing function
233 loggerTraceFlush :: Logger -> IO ()
234 loggerTraceFlush logger = trace_flush logger
235
236 -- | Default trace flushing function (flush stderr)
237 defaultTraceFlush :: IO ()
238 defaultTraceFlush = hFlush stderr
239
240 initLogger :: IO Logger
241 initLogger = do
242 dumps <- newIORef Set.empty
243 return $ Logger
244 { log_hook = []
245 , dump_hook = []
246 , trace_hook = []
247 , generated_dumps = dumps
248 , trace_flush = defaultTraceFlush
249 , logFlags = defaultLogFlags
250 }
251
252 -- | Log something
253 putLogMsg :: Logger -> LogAction
254 putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)
255
256 -- | Dump something
257 putDumpFile :: Logger -> DumpAction
258 putDumpFile logger =
259 let
260 fallback = putLogMsg logger
261 dumps = generated_dumps logger
262 deflt = defaultDumpAction dumps fallback
263 in foldr ($) deflt (dump_hook logger)
264
265 -- | Trace something
266 putTraceMsg :: Logger -> TraceAction a
267 putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)
268
269
270 -- | Push a log hook
271 pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger
272 pushLogHook h logger = logger { log_hook = h:log_hook logger }
273
274 -- | Pop a log hook
275 popLogHook :: Logger -> Logger
276 popLogHook logger = case log_hook logger of
277 [] -> panic "popLogHook: empty hook stack"
278 _:hs -> logger { log_hook = hs }
279
280 -- | Push a dump hook
281 pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger
282 pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }
283
284 -- | Pop a dump hook
285 popDumpHook :: Logger -> Logger
286 popDumpHook logger = case dump_hook logger of
287 [] -> panic "popDumpHook: empty hook stack"
288 _:hs -> logger { dump_hook = hs }
289
290 -- | Push a trace hook
291 pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger
292 pushTraceHook h logger = logger { trace_hook = h:trace_hook logger }
293
294 -- | Pop a trace hook
295 popTraceHook :: Logger -> Logger
296 popTraceHook logger = case trace_hook logger of
297 [] -> panic "popTraceHook: empty hook stack"
298 _ -> logger { trace_hook = tail (trace_hook logger) }
299
300 -- | Make the logger thread-safe
301 makeThreadSafe :: Logger -> IO Logger
302 makeThreadSafe logger = do
303 lock <- newMVar ()
304 let
305 with_lock :: forall a. IO a -> IO a
306 with_lock act = withMVar lock (const act)
307
308 log action logflags msg_class loc doc =
309 with_lock (action logflags msg_class loc doc)
310
311 dmp action logflags sty opts str fmt doc =
312 with_lock (action logflags sty opts str fmt doc)
313
314 trc :: forall a. TraceAction a -> TraceAction a
315 trc action logflags str doc v =
316 unsafePerformIO (with_lock (return $! action logflags str doc v))
317
318 return $ pushLogHook log
319 $ pushDumpHook dmp
320 $ pushTraceHook trc
321 $ logger
322
323 -- See Note [JSON Error Messages]
324 --
325 jsonLogAction :: LogAction
326 jsonLogAction _ (MCDiagnostic SevIgnore _) _ _ = return () -- suppress the message
327 jsonLogAction logflags msg_class srcSpan msg
328 =
329 defaultLogActionHPutStrDoc logflags True stdout
330 (withPprStyle (PprCode CStyle) (doc $$ text ""))
331 where
332 str = renderWithContext (log_default_user_context logflags) msg
333 doc = renderJSON $
334 JSObject [ ( "span", json srcSpan )
335 , ( "doc" , JSString str )
336 , ( "messageClass", json msg_class )
337 ]
338
339 defaultLogAction :: LogAction
340 defaultLogAction logflags msg_class srcSpan msg
341 | log_dopt Opt_D_dump_json logflags = jsonLogAction logflags msg_class srcSpan msg
342 | otherwise = case msg_class of
343 MCOutput -> printOut msg
344 MCDump -> printOut (msg $$ blankLine)
345 MCInteractive -> putStrSDoc msg
346 MCInfo -> printErrs msg
347 MCFatal -> printErrs msg
348 MCDiagnostic SevIgnore _ -> pure () -- suppress the message
349 MCDiagnostic sev rea -> printDiagnostics sev rea
350 where
351 printOut = defaultLogActionHPrintDoc logflags False stdout
352 printErrs = defaultLogActionHPrintDoc logflags False stderr
353 putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout
354 -- Pretty print the warning flag, if any (#10752)
355 message sev rea = mkLocMessageAnn (flagMsg sev rea) msg_class srcSpan msg
356
357 printDiagnostics severity reason = do
358 hPutChar stderr '\n'
359 caretDiagnostic <-
360 if log_show_caret logflags
361 then getCaretDiagnostic msg_class srcSpan
362 else pure empty
363 printErrs $ getPprStyle $ \style ->
364 withPprStyle (setStyleColoured True style)
365 (message severity reason $+$ caretDiagnostic)
366 -- careful (#2302): printErrs prints in UTF-8,
367 -- whereas converting to string first and using
368 -- hPutStr would just emit the low 8 bits of
369 -- each unicode char.
370
371 flagMsg :: Severity -> DiagnosticReason -> Maybe String
372 flagMsg SevIgnore _ = panic "Called flagMsg with SevIgnore"
373 flagMsg SevError WarningWithoutFlag = Just "-Werror"
374 flagMsg SevError (WarningWithFlag wflag) = do
375 let name = NE.head (warnFlagNames wflag)
376 return $
377 "-W" ++ name ++ warnFlagGrp wflag ++
378 ", -Werror=" ++ name
379 flagMsg SevError ErrorWithoutFlag = Nothing
380 flagMsg SevWarning WarningWithoutFlag = Nothing
381 flagMsg SevWarning (WarningWithFlag wflag) = do
382 let name = NE.head (warnFlagNames wflag)
383 return ("-W" ++ name ++ warnFlagGrp wflag)
384 flagMsg SevWarning ErrorWithoutFlag =
385 panic "SevWarning with ErrorWithoutFlag"
386
387 warnFlagGrp flag
388 | log_show_warn_groups logflags =
389 case smallestWarningGroups flag of
390 [] -> ""
391 groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"
392 | otherwise = ""
393
394 -- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.
395 defaultLogActionHPrintDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
396 defaultLogActionHPrintDoc logflags asciiSpace h d
397 = defaultLogActionHPutStrDoc logflags asciiSpace h (d $$ text "")
398
399 -- | The boolean arguments let's the pretty printer know if it can optimize indent
400 -- by writing ascii ' ' characters without going through decoding.
401 defaultLogActionHPutStrDoc :: LogFlags -> Bool -> Handle -> SDoc -> IO ()
402 defaultLogActionHPutStrDoc logflags asciiSpace h d
403 -- Don't add a newline at the end, so that successive
404 -- calls to this log-action can output all on the same line
405 = printSDoc (log_default_user_context logflags) (Pretty.PageMode asciiSpace) h d
406
407 --
408 -- Note [JSON Error Messages]
409 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
410 --
411 -- When the user requests the compiler output to be dumped as json
412 -- we used to collect them all in an IORef and then print them at the end.
413 -- This doesn't work very well with GHCi. (See #14078) So instead we now
414 -- use the simpler method of just outputting a JSON document inplace to
415 -- stdout.
416 --
417 -- Before the compiler calls log_action, it has already turned the `ErrMsg`
418 -- into a formatted message. This means that we lose some possible
419 -- information to provide to the user but refactoring log_action is quite
420 -- invasive as it is called in many places. So, for now I left it alone
421 -- and we can refine its behaviour as users request different output.
422
423 -- | Default action for 'dumpAction' hook
424 defaultDumpAction :: DumpCache -> LogAction -> DumpAction
425 defaultDumpAction dumps log_action logflags sty flag title _fmt doc =
426 dumpSDocWithStyle dumps log_action sty logflags flag title doc
427
428 -- | Write out a dump.
429 --
430 -- If --dump-to-file is set then this goes to a file.
431 -- otherwise emit to stdout (via the the LogAction parameter).
432 --
433 -- When @hdr@ is empty, we print in a more compact format (no separators and
434 -- blank lines)
435 dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> LogFlags -> DumpFlag -> String -> SDoc -> IO ()
436 dumpSDocWithStyle dumps log_action sty logflags flag hdr doc =
437 withDumpFileHandle dumps logflags flag writeDump
438 where
439 -- write dump to file
440 writeDump (Just handle) = do
441 doc' <- if null hdr
442 then return doc
443 else do timeStamp <- if log_enable_timestamps logflags
444 then (text . show) <$> getCurrentTime
445 else pure empty
446 let d = timeStamp
447 $$ blankLine
448 $$ doc
449 return $ mkDumpDoc hdr d
450 -- When we dump to files we use UTF8. Which allows ascii spaces.
451 defaultLogActionHPrintDoc logflags True handle (withPprStyle sty doc')
452
453 -- write the dump to stdout
454 writeDump Nothing = do
455 let (doc', msg_class)
456 | null hdr = (doc, MCOutput)
457 | otherwise = (mkDumpDoc hdr doc, MCDump)
458 log_action logflags msg_class noSrcSpan (withPprStyle sty doc')
459
460
461 -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a
462 -- file, otherwise 'Nothing'.
463 withDumpFileHandle :: DumpCache -> LogFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()
464 withDumpFileHandle dumps logflags flag action = do
465 let mFile = chooseDumpFile logflags flag
466 case mFile of
467 Just fileName -> do
468 gd <- readIORef dumps
469 let append = Set.member fileName gd
470 mode = if append then AppendMode else WriteMode
471 unless append $
472 writeIORef dumps (Set.insert fileName gd)
473 createDirectoryIfMissing True (takeDirectory fileName)
474 withFile fileName mode $ \handle -> do
475 -- We do not want the dump file to be affected by
476 -- environment variables, but instead to always use
477 -- UTF8. See:
478 -- https://gitlab.haskell.org/ghc/ghc/issues/10762
479 hSetEncoding handle utf8
480
481 action (Just handle)
482 Nothing -> action Nothing
483
484 -- | Choose where to put a dump file based on LogFlags and DumpFlag
485 chooseDumpFile :: LogFlags -> DumpFlag -> Maybe FilePath
486 chooseDumpFile logflags flag
487 | log_dump_to_file logflags || forced_to_file
488 , Just prefix <- getPrefix
489 = Just $ setDir (prefix ++ dump_suffix)
490
491 | otherwise
492 = Nothing
493 where
494 (forced_to_file, dump_suffix) = case flag of
495 -- -dth-dec-file dumps expansions of TH
496 -- splices into MODULE.th.hs even when
497 -- -ddump-to-file isn't set
498 Opt_D_th_dec_file -> (True, "th.hs")
499 _ -> (False, default_suffix)
500
501 -- build a suffix from the flag name
502 -- e.g. -ddump-asm => ".dump-asm"
503 default_suffix = map (\c -> if c == '_' then '-' else c) $
504 let str = show flag
505 in case stripPrefix "Opt_D_" str of
506 Just x -> x
507 Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str)
508
509 getPrefix
510 -- dump file location is being forced
511 -- by the --ddump-file-prefix flag.
512 | Just prefix <- log_dump_prefix_override logflags
513 = Just prefix
514 -- dump file location chosen by GHC.Driver.Pipeline.runPipeline
515 | Just prefix <- log_dump_prefix logflags
516 = Just prefix
517 -- we haven't got a place to put a dump file.
518 | otherwise
519 = Nothing
520 setDir f = case log_dump_dir logflags of
521 Just d -> d </> f
522 Nothing -> f
523
524
525
526 -- | Default action for 'traceAction' hook
527 defaultTraceAction :: TraceAction a
528 defaultTraceAction logflags title doc x =
529 if not (log_enable_debug logflags)
530 then x
531 else trace (renderWithContext (log_default_dump_context logflags)
532 (sep [text title, nest 2 doc])) x
533
534
535 -- | Log something
536 logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
537 logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg
538
539 -- | Dump something
540 logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
541 logDumpFile logger = putDumpFile logger (logFlags logger)
542
543 -- | Log a trace message
544 logTraceMsg :: Logger -> String -> SDoc -> a -> a
545 logTraceMsg logger hdr doc a = putTraceMsg logger (logFlags logger) hdr doc a
546
547 -- | Log a dump message (not a dump file)
548 logDumpMsg :: Logger -> String -> SDoc -> IO ()
549 logDumpMsg logger hdr doc = logMsg logger MCDump noSrcSpan
550 (withPprStyle defaultDumpStyle
551 (mkDumpDoc hdr doc))
552
553 mkDumpDoc :: String -> SDoc -> SDoc
554 mkDumpDoc hdr doc
555 = vcat [blankLine,
556 line <+> text hdr <+> line,
557 doc,
558 blankLine]
559 where
560 line = text "===================="
561
562
563 -- | Dump if the given DumpFlag is set
564 putDumpFileMaybe :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
565 putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify
566 {-# INLINE putDumpFileMaybe #-} -- see Note [INLINE conditional tracing utilities]
567
568 -- | Dump if the given DumpFlag is set
569 --
570 -- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument
571 putDumpFileMaybe'
572 :: Logger
573 -> PrintUnqualified
574 -> DumpFlag
575 -> String
576 -> DumpFormat
577 -> SDoc
578 -> IO ()
579 putDumpFileMaybe' logger printer flag hdr fmt doc
580 = when (logHasDumpFlag logger flag) $
581 logDumpFile' logger printer flag hdr fmt doc
582 {-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities]
583
584
585 logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag
586 -> String -> DumpFormat -> SDoc -> IO ()
587 {-# NOINLINE logDumpFile' #-}
588 -- NOINLINE: Now we are past the conditional, into the "cold" path,
589 -- don't inline, to reduce code size at the call site
590 -- See Note [INLINE conditional tracing utilities]
591 logDumpFile' logger printer flag hdr fmt doc
592 = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc
593
594 -- | Ensure that a dump file is created even if it stays empty
595 touchDumpFile :: Logger -> DumpFlag -> IO ()
596 touchDumpFile logger flag =
597 withDumpFileHandle (generated_dumps logger) (logFlags logger) flag (const (return ()))
598
599 class HasLogger m where
600 getLogger :: m Logger
601
602 class ContainsLogger t where
603 extractLogger :: t -> Logger
604