never executed always true always false

    1 {-# LANGUAGE RankNTypes #-}
    2 {-# LANGUAGE DerivingVia #-}
    3 module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)
    4                                   , newLogQueue
    5                                   , finishLogQueue
    6                                   , writeLogQueue
    7                                   , parLogAction
    8                                   , printLogs
    9 
   10                                   , LogQueueQueue(..)
   11                                   , initLogQueue
   12                                   , allLogQueues
   13                                   , newLogQueueQueue
   14                                   , dequeueLogQueueQueue
   15                                   ) where
   16 
   17 import GHC.Prelude
   18 import Control.Concurrent
   19 import Data.IORef
   20 import GHC.Types.Error
   21 import GHC.Types.SrcLoc
   22 import GHC.Utils.Logger
   23 import qualified Data.IntMap as IM
   24 import Control.Concurrent.STM
   25 
   26 -- LogQueue Abstraction
   27 
   28 -- | Each module is given a unique 'LogQueue' to redirect compilation messages
   29 -- to. A 'Nothing' value contains the result of compilation, and denotes the
   30 -- end of the message queue.
   31 data LogQueue = LogQueue { logQueueId :: !Int
   32                          , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
   33                          , logQueueSemaphore :: !(MVar ())
   34                          }
   35 
   36 newLogQueue :: Int -> IO LogQueue
   37 newLogQueue n = do
   38   mqueue <- newIORef []
   39   sem <- newMVar ()
   40   return (LogQueue n mqueue sem)
   41 
   42 finishLogQueue :: LogQueue -> IO ()
   43 finishLogQueue lq = do
   44   writeLogQueueInternal lq Nothing
   45 
   46 
   47 writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
   48 writeLogQueue lq msg = do
   49   writeLogQueueInternal lq (Just msg)
   50 
   51 -- | Internal helper for writing log messages
   52 writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
   53 writeLogQueueInternal (LogQueue _n ref sem) msg = do
   54     atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
   55     _ <- tryPutMVar sem ()
   56     return ()
   57 
   58 -- The log_action callback that is used to synchronize messages from a
   59 -- worker thread.
   60 parLogAction :: LogQueue -> LogAction
   61 parLogAction log_queue log_flags !msgClass !srcSpan !msg =
   62     writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags)
   63 
   64 -- Print each message from the log_queue using the global logger
   65 printLogs :: Logger -> LogQueue -> IO ()
   66 printLogs !logger (LogQueue _n ref sem) = read_msgs
   67   where read_msgs = do
   68             takeMVar sem
   69             msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
   70             print_loop msgs
   71 
   72         print_loop [] = read_msgs
   73         print_loop (x:xs) = case x of
   74             Just (msgClass,srcSpan,msg,flags) -> do
   75                 logMsg (setLogFlags logger flags) msgClass srcSpan msg
   76                 print_loop xs
   77             -- Exit the loop once we encounter the end marker.
   78             Nothing -> return ()
   79 
   80 -- The LogQueueQueue abstraction
   81 
   82 data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue)
   83 
   84 newLogQueueQueue :: LogQueueQueue
   85 newLogQueueQueue = LogQueueQueue 1 IM.empty
   86 
   87 addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue
   88 addToQueueQueue lq (LogQueueQueue n im) = LogQueueQueue n (IM.insert (logQueueId lq) lq im)
   89 
   90 initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()
   91 initLogQueue lqq lq = modifyTVar lqq (addToQueueQueue lq)
   92 
   93 -- | Return all items in the queue in ascending order
   94 allLogQueues :: LogQueueQueue -> [LogQueue]
   95 allLogQueues (LogQueueQueue _n im) = IM.elems im
   96 
   97 dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)
   98 dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of
   99                                                 Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')
  100                                                 _ -> Nothing
  101