+section: compiler

+synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter

+description: The ``recover`` method in TemplateHaskell now behaves the same 

+  with the internal and external interpreter.

+  In the past, when an error was encountered in a computation in a ``recover`` block,

+  the external interpreter would discard any state changes from ``putQ``,

+  whereas the internal interpreter would not.

+  This was a long-standing error in the implementation of the external interpreter.

+  Both now keep state changes from ``putQ`` in ``recover`` blocks.

+mrs: !15994

+issues: #27022

+      -- This information is only used to populate the 'eps_is_boot' field.

+Note [Structure of dep_boot_mods]

+          , isWinHost                        ? arg "-optl-Wl,--disable-runtime-pseudo-reloc"

+newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a }

+  fmap f (GHCiQ m) = GHCiQ $ fmap f . m

+    do f'  <- runGHCiQ f s

+       a' <- runGHCiQ a s

+       return $ f' a'

+  pure x = GHCiQ $ \_ -> return x

+    do m'  <- runGHCiQ m s

+       a <- runGHCiQ (f m') s

+       return a

+  fail err  = GHCiQ $ \sRef -> readIORef sRef >>= \s -> throwIO (GHCiQException s err)

+getState = GHCiQ $ \sRef -> readIORef sRef

+ghcCmd m = GHCiQ $ \sRef -> do

+  s <- readIORef sRef

+    THComplete res -> return res

+  liftIO m = GHCiQ $ \_ -> m

+  qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do

+    s <- readIORef sRef

+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef

+      Left GHCiQException{} -> h sRef

+  qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=

+  qGetQ = do

+    s <- getState

+    return $ lookup (qsMap s)

+  qPutQ k = GHCiQ $ \sRef ->

+    modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })

+  qstate' <- newIORef $ qstate { qsPipe = pipe }

+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'

+  modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })

+  r <- runGHCiQ (TH.runQ ghciq) qstateref

+#if defined(mingw32_HOST_OS)

+/* Global var (only on Windows) that is exported (hence before BeginPrivate.h)

+ * to be shared with the I/O code in the base library to tell us which style

+ * of I/O manager we are using: one that uses the Windows native API HANDLEs,

+ * or one that uses Posix style fds.

+ */

+extern bool rts_IOManagerIsWin32Native;

+#endif

+

+    initLinkerRtsSyms(symhash);

+void initLinkerRtsSyms(StrHashTable *symhash);

+

+#include "LinkerInternals.h"

+#include "PathUtils.h"

+ *

+ * Note [Naming Scheme for Symbol Macros]

+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+ *

+ * SymI_*: symbol is internal to the RTS. It resides in an object

+ *         file/library that is linked into the RTS library (as a static

+ *         archive or dynamic shared library).

+ * SymE_*: symbol is external to the RTS library. It might be linked

+ *         dynamically.

+ *

+ * Sym*_HasProto  : the symbol prototype is imported in an include file

+ *                  or defined explicitly

+ * Sym*_NeedsProto: the symbol is undefined and we add a dummy

+ *                  default proto extern void sym(void);

+      SymI_HasDataProto(rts_IOManagerIsWin32Native)          \

+      SymI_HasDataProto(RtsFlags)                                           \

+      SymI_HasDataProto(n_capabilities)                                     \

+      SymI_HasDataProto(max_n_capabilities)                                 \

+      SymI_HasDataProto(enabled_capabilities)                               \

+/* Declare prototypes for the symbols that need it, so we can refer

+ * to them in the rtsSyms table below.

+ *

+ * In particular, for the external ones (SymE_*) we use the dllimport attribute

+ * to indicate that (on Windows) they come from external DLLs. This attribute

+ * is ignored on other platforms.

+ *

+ * The claims about the types of these symbols are entirely bogus.

+ */

+#if defined(mingw32_HOST_OS) && defined(DYNAMIC)

+#define DLLIMPORT __attribute__((dllimport))

+#else

+#define DLLIMPORT /**/

+#endif

+

+#define SymI_NeedsProto(vvv)      extern           void vvv(void);

+#define SymI_NeedsDataProto(vvv)  extern           StgWord vvv[];

+#define SymE_NeedsProto(vvv)      extern DLLIMPORT void vvv(void);

+#define SymE_NeedsDataProto(vvv)  extern DLLIMPORT StgWord vvv[];

+

+#define SymE_HasProto(vvv) /**/

+/* See Note [Naming Scheme for Symbol Macros] */

+

+

+

+/* Initialize (if not already initialized) and return an array of symbols with stuff from the RTS. */

+void initLinkerRtsSyms (StrHashTable *symhash) {

+    /* The address of data symbols with the dllimport attribute are not

+     * compile-time constants and so cannot be used in constant initialisers.

+     * For this reason, rtsSyms is a local variable within this function

+     * rather than a global constant (as it was historically).

+     */

+    const RtsSymbolVal rtsSyms[] = {

+    };

+

+    IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));

+    for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {

+        IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));

+        if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),

+                                    symhash, sym->lbl, sym->addr,

+                                    sym->strength, sym->type, 0, NULL)) {

+            barf("ghciInsertSymbolTable failed");

+        }

+    }

+    IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));

+}

+

+{-# LANGUAGE TypeApplications           #-}

+import Control.Exception

+  ( SomeException, displayException, evaluate, try )

+runPropertyCheck pcThunk = do

+  -- See Note [Catching exceptions in property evaluation].

+  pcRes <- liftIO $ try @SomeException (evaluate pcThunk)

+  case pcRes of

+    Left  e -> reportFailure ("Failure: exception: " ++ displayException e)

+    Right (PropertyAnd a b) ->

+      (<>) <$> runPropertyCheck a <*> runPropertyCheck b

+    Right (PropertyBinaryOp ok desc s1 s2) -> do

+      okRes <- liftIO $ try @SomeException (evaluate ok)

+      case okRes of

+        Right True  -> return Success

+        Right False -> reportFailure ("Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2)

+        Left  e     -> reportFailure ("Failure: exception: " ++ displayException e)

+

+reportFailure :: String -> ReaderT RunS IO Result

+reportFailure msg = do

+  ctx <- context <$> ask

+  putMsg msg

+  return (Failure [msg : ctx])

+

+-- Note [Catching exceptions in property evaluation]

+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+-- A property like `\a b -> let !r = a `div` 0 in r === b` builds a

+-- `PropertyCheck` thunk whose forcing raises an exception -- in this case

+-- already at the `PropertyBinaryOp` constructor, before its `ok` field is

+-- ever inspected. Other properties may force `ok = (s1 == s2)` instead and

+-- raise from there.

+--

+-- To handle both, we `evaluate` first the `PropertyCheck` thunk and then

+-- the `ok` field, each inside `try`, and report any exception through the

+-- normal `reportFailure` path. The surrounding loop then still prints

+-- "With arguments ... (Seed: ...)" and the test driver continues with

+-- subsequent properties instead of aborting.

+-- | Divisibility test for Bounded Integral types (Int, Int{8,16,32,64},

+-- Word, Word{8,16,32,64}).

+testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)

+testDivisible _ = Group "Divisible"

+    [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->

+            -- See Note [Skipping minBound `div` (-1)].

+            if (minBound :: a) < 0 && a == minBound && b == (-1)

+              then True === True

+              else a === (a `div` b) * b + (a `mod` b)

+    ]

+

+-- | Divisibility test for unbounded Integral types (Integer). No overflow

+-- can occur here, so the property holds without exception for all NonZero b.

+testDivisibleUnbounded :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)

+                       => Proxy a -> Test

+testDivisibleUnbounded _ = Group "Divisible"

+-- Note [Skipping minBound `div` (-1)]

+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+-- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises

+-- ArithException(Overflow) because `-minBound` is not representable in the

+-- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod

+-- identity property cannot hold there, so we skip exactly that one pair.

+--

+-- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N},

+-- False for Word{N}. This way unsigned Bounded types lose no coverage,

+-- and only the genuine overflow sample is skipped for signed types.

+--

+-- For the unbounded `Integer`, no overflow can occur and we use a separate

+-- 'testDivisibleUnbounded' (without the Bounded constraint or the skip).

+-- See #27222.

+

+testNumber :: (Show a, Eq a, Prelude.Num a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a)

+    , testDivisible proxy

+    , testOperatorPrecedence proxy

+    ]

+

+-- | Variant of 'testNumber' for unbounded Integral types (e.g., Integer).

+testNumberUnbounded :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)

+                    => String -> Proxy a -> Test

+testNumberUnbounded name proxy = Group name

+    [ testIntegral proxy

+    , testEqOrd proxy

+    , testAdditive proxy

+    , testMultiplicative proxy

+    , testDivisibleUnbounded proxy

+    , testNumberUnbounded "Integer" (Proxy :: Proxy Integer)

+  , testPrimopMayOflo "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#

+-- | Compare two 'mulIntMayOflo#'-like primops only on whether their result

+-- is zero. See Note [Comparing mulIntMayOflo# results].

+testPrimopMayOflo :: String

+                  -> (Int# -> Int# -> Int#)

+                  -> (Int# -> Int# -> Int#)

+                  -> Test

+testPrimopMayOflo s l r =

+    Property s $ \ (uInt# -> x0) (uInt# -> x1) ->

+        (wInt# (l x0 x1) == 0) === (wInt# (r x0 x1) == 0)

+

+-- Note [Comparing mulIntMayOflo# results]

+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+-- The 'mulIntMayOflo#' primop is only specified to return 0 if the signed

+-- multiplication does not overflow, and a non-zero value if it /may/

+-- overflow (see Note [MO_S_MulMayOflo significant width] in

+-- GHC.Cmm.MachOp). The exact non-zero value is unspecified and legitimately

+-- differs between backends and between inlined vs. non-inlined call sites

+-- (e.g., the LLVM backend's `isSMulOK` returns `sext_signbit(low) - high`,

+-- which is some arbitrary non-zero word on overflow).

+--

+-- Comparing the raw Int# results bit-for-bit is therefore too strict and

+-- causes spurious test failures whenever the random arguments happen to

+-- overflow. We compare zero/non-zero instead, which matches the spec.

+-- See #27222.

+

+{-# LANGUAGE TemplateHaskell #-}

+-- | This tests the behaviour of TH's recover method.

+-- It should behave the same in the internal and external interperter.

+-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not.

+module Main where

+

+import Language.Haskell.TH.Syntax

+main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops")  >> getQ @String >>= lift )

+Just "42"

+test('T27022', normal, compile_and_run, [''])