{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , MagicHash
           , PatternSynonyms
  #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.Exception
-- Copyright   :  (c) The University of Glasgow, 1998-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  ghc-devs@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Exceptions and exception-handling functions.
--
-- /The API of this module is unstable and not meant to be consumed by the general public./
-- If you absolutely must depend on it, make sure to use a tight upper
-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can
-- change rapidly without much warning.
--
-----------------------------------------------------------------------------

module GHC.Internal.Exception
    ( -- * 'Exception' class
      Exception(..)

      -- * 'SomeException'
    , SomeException(..)
    , displayExceptionWithInfo

      -- * Exception context
    , someExceptionContext
    , addExceptionContext

      -- * Throwing
    , throw

      -- * Concrete exceptions
      -- ** Arithmetic exceptions
    , ArithException(..)
    , divZeroException
    , overflowException
    , ratioZeroDenomException
    , underflowException
      -- ** 'ErrorCall'
    , ErrorCall(.., ErrorCallWithLocation)
    , errorCallException
    , errorCallWithCallStackException
    , toExceptionWithBacktrace

      -- * Reexports
      -- Re-export CallStack and SrcLoc from GHC.Internal.Types
    , CallStack, fromCallSiteList, getCallStack, prettyCallStack
    , prettyCallStackLines
    , SrcLoc(..), prettySrcLoc
    ) where

import GHC.Internal.Base
import GHC.Internal.Show
import GHC.Internal.Stack.Types
import GHC.Internal.IO.Unsafe
import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack)
import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces)
import GHC.Internal.Exception.Type

-- | Throw an exception.  Exceptions may be thrown from purely
-- functional code, but may only be caught within the 'IO' monad.
--
-- WARNING: You may want to use 'throwIO' instead so that your pure code
-- stays exception-free.
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
         (HasCallStack, Exception e) => e -> a
throw :: forall a e. (HasCallStack, Exception e) => e -> a
throw e
e =
    -- Note the absolutely crucial bang "!" on this binding!
    --   See Note [Capturing the backtrace in throw]
    -- Note also the absolutely crucial `noinine` in the RHS!
    --   See Note [Hiding precise exception signature in throw]
    let se :: SomeException
        !se :: SomeException
se = SomeException -> SomeException
forall a. a -> a
noinline (IO SomeException -> SomeException
forall a. IO a -> a
unsafePerformIO (e -> IO SomeException
forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace e
e))
    in SomeException -> a
forall a b. a -> b
raise# SomeException
se

-- Note [Capturing the backtrace in throw]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- When `throw` captures a backtrace, it must be the backtrace *at the moment
-- that `throw` is called*.   That is why the binding of `se` is marked strict,
-- via the `!`:
--
--     !se = <rhs>
--
-- GHC can capture /four/ different sorts of backtraces (See Note [Backtrace
-- mechanisms] in "Control.Exception.Backtrace" for details). One of them
-- (`CallStack` constraints) does not need this strict-binding treatment,
-- because the `CallStack` constraint is captured in the thunk. However, the
-- other two (DWARF stack unwinding, and native Haskell stack unwinding) are
-- much more fragile, and can only be captured right at the call of `throw`.
--
-- However, making `se` strict has downsides: see
-- Note [Hiding precise exception signature in throw] below.
--
--
-- Note [Hiding precise exception signature in throw]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In 'throw' we use `unsafePerformIO . toExceptionWithBacktrace' to collect
-- the backtraces which will be attached as the exception's 'ExceptionContext'.
-- We must ensure that this is evaluated immediately in `throw` since
-- `toExceptionWithBacktrace` must capture the execution state at the moment
-- that the exception is thrown (see Note [Capturing the backtrace in throw]).
-- Unfortunately, unless we take particular care this can lead to a
-- catastrophic regression in 'throw's demand signature which will infect
-- all callers (#25066)
--
-- Specifically, GHC's demand analysis has an approximate heuristic for tracking
-- whether divergent functions diverge with precise or imprecise exceptions (namely
-- the 'ExnOrDiv' and 'Diverges' constructors of 'GHC.Types.Demand.Divergence',
-- respectively). This is because we can take considerably more liberties in
-- optimising around functions which are known not to diverge via precise
-- exception (see Note [Precise exceptions and strictness analysis]).
-- For this reason, it is important that 'throw' have a 'Diverges' divergence
-- type.
--
-- Unfortunately, this is broken if we allow `unsafePerformIO` to inline. Specifically,
-- if we allow this inlining we will end up with Core of the form:
--
--   throw = \e ->
--     case runRW# (\s -> ... toExceptionWithBacktrace e s ...) of
--       se -> raise# se
--
-- so far this is fine; the demand analyzer's divergence heuristic
-- will give 'throw' the expected 'Diverges' divergence.
--
-- However, the simplifier will subsequently notice that `raise#` can be fruitfully
-- floated into the body of the `runRW#`:
--
--   throw = \e ->
--     runRW# (\s -> case toExceptionWithBacktrace e s of
--                     (# s', se #) -> raise# se)
--
-- This is problematic as one of the demand analyser's heuristics examines
-- `case` scrutinees, looking for those that result in a `RealWorld#` token
-- (see Note [Which scrutinees may throw precise exceptions], test (1)). The
-- `case toExceptionWithBacktrace e of ...` here fails this check, causing the
-- heuristic to conclude that `throw` may indeed diverge with a precise
-- exception. This resulted in the significant performance regression noted in
-- #25066.
--
-- To avoid this, we use `noinline` to ensure that `unsafePerformIO` does not unfold,
-- meaning that the `raise#` cannot be floated under the `toExceptionWithBacktrace`
-- case analysis.
--
-- Ultimately this is a bit of a horrible hack; the right solution would be to have
-- primops which allow more precise guidance of the demand analyser's heuristic
-- (e.g. #23847).

-- | @since base-4.20.0.0
toExceptionWithBacktrace :: (HasCallStack, Exception e)
                         => e -> IO SomeException
toExceptionWithBacktrace :: forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace e
e
  | e -> Bool
forall e. Exception e => e -> Bool
backtraceDesired e
e = do
      bt <- IO Backtraces
HasCallStack => IO Backtraces
collectBacktraces
      return (addExceptionContext bt (toException e))
  | Bool
otherwise = SomeException -> IO SomeException
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)

-- | This is thrown when the user calls 'error'. The @String@ is the
-- argument given to 'error'.
--
-- Historically, there was a second @String@ for the location, but it was subsumed by the backtrace mechanisms (since base-4.22).
data ErrorCall = ErrorCall String
    deriving ( ErrorCall -> ErrorCall -> Bool
(ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool) -> Eq ErrorCall
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorCall -> ErrorCall -> Bool
== :: ErrorCall -> ErrorCall -> Bool
$c/= :: ErrorCall -> ErrorCall -> Bool
/= :: ErrorCall -> ErrorCall -> Bool
Eq  -- ^ @since base-4.7.0.0
             , Eq ErrorCall
Eq ErrorCall =>
(ErrorCall -> ErrorCall -> Ordering)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> ErrorCall)
-> (ErrorCall -> ErrorCall -> ErrorCall)
-> Ord ErrorCall
ErrorCall -> ErrorCall -> Bool
ErrorCall -> ErrorCall -> Ordering
ErrorCall -> ErrorCall -> ErrorCall
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ErrorCall -> ErrorCall -> Ordering
compare :: ErrorCall -> ErrorCall -> Ordering
$c< :: ErrorCall -> ErrorCall -> Bool
< :: ErrorCall -> ErrorCall -> Bool
$c<= :: ErrorCall -> ErrorCall -> Bool
<= :: ErrorCall -> ErrorCall -> Bool
$c> :: ErrorCall -> ErrorCall -> Bool
> :: ErrorCall -> ErrorCall -> Bool
$c>= :: ErrorCall -> ErrorCall -> Bool
>= :: ErrorCall -> ErrorCall -> Bool
$cmax :: ErrorCall -> ErrorCall -> ErrorCall
max :: ErrorCall -> ErrorCall -> ErrorCall
$cmin :: ErrorCall -> ErrorCall -> ErrorCall
min :: ErrorCall -> ErrorCall -> ErrorCall
Ord -- ^ @since base-4.7.0.0
             )

{-# DEPRECATED ErrorCallWithLocation "ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively." #-}
pattern ErrorCallWithLocation :: String -> String -> ErrorCall
pattern $mErrorCallWithLocation :: forall {r}.
ErrorCall -> (String -> String -> r) -> ((# #) -> r) -> r
$bErrorCallWithLocation :: String -> String -> ErrorCall
ErrorCallWithLocation err loc <- ErrorCall ((\String
err -> (String
err, String -> String
forall a. HasCallStack => String -> a
error String
"ErrorCallWithLocation has been deprecated in favour of ErrorCall (which does not have a location). Backtraces are now handled by the backtrace exception mechanisms exclusively.")) -> (err, loc))
  where ErrorCallWithLocation String
err String
_ = String -> ErrorCall
ErrorCall String
err
{-# COMPLETE ErrorCallWithLocation #-}

-- | @since base-4.0.0.0
instance Exception ErrorCall

-- | @since base-4.0.0.0
instance Show ErrorCall where
  showsPrec :: Int -> ErrorCall -> String -> String
showsPrec Int
_ (ErrorCall String
err) = String -> String -> String
showString String
err

errorCallException :: String -> SomeException
errorCallException :: String -> SomeException
errorCallException String
s = ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
s)

errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException String
s CallStack
stk = IO SomeException -> SomeException
forall a. IO a -> a
unsafeDupablePerformIO (IO SomeException -> SomeException)
-> IO SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ do
    (HasCallStack => IO SomeException) -> IO SomeException
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO SomeException) -> IO SomeException)
-> (HasCallStack => IO SomeException) -> IO SomeException
forall a b. (a -> b) -> a -> b
$ ErrorCall -> IO SomeException
forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace (String -> ErrorCall
ErrorCall String
s)
  where ?callStack = HasCallStack
CallStack
stk