+section: compiler

+issues: #25926 #27124

+mrs: !15895

+synopsis:

+  Fix "failed to detect OverLit" panic in the pattern-match checker.

+description:

+  Fixed an issue in which overloaded literals (e.g. numeric literals, overloaded

+  strings with -XOverloadedStrings, overloaded lists, etc) could cause a GHC

+  crash when using -fdefer-type-errors, with an error message of the form

+  "failed to detect OverLit".

+section: codegen

+synopsis: Fix module finalizers on multiple platforms

+description: {

+  GHC-generated module finalizers (e.g. ``hs_spt_remove`` for the Static

+  Pointer Table) now run correctly on ELF platforms, darwin, wasm32 and

+  Windows. Also fixes running finalizers when unloading objects with the

+  RTS linker.

+}

+issues: #27072

+mrs: !15762

+        -- NB: keep this in sync with GHC.HsToCore.Pmc.Solver.Types.coreExprAsPmLit,

+        -- as that also needs to see through these magic Ids.

+

+                  ; emitFinalizerDecls this_mod stubs

+emitInitializerDecls, emitFinalizerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup ()

+emitInitializerDecls = emitInitFiniArrayDecls InitArray mkInitializerArrayLabel getInitializers

+emitFinalizerDecls   = emitInitFiniArrayDecls FiniArray mkFinalizerArrayLabel   getFinalizers

+

+emitInitFiniArrayDecls :: SectionType -> (Module -> CLabel) -> (CStub -> [CLabel])

+                       -> Module -> ForeignStubs -> CgStream RawCmmGroup ()

+emitInitFiniArrayDecls sect_type mk_lbl get_labels this_mod (ForeignStubs _ cstub)

+  | labels <- get_labels cstub

+  , not $ null labels =

+      let lbl     = mk_lbl this_mod

+          sect    = Section sect_type lbl

+            | fn_name <- labels

+    in Stream.yield [CmmData sect statics]

+emitInitFiniArrayDecls _ _ _ _ _ = return ()

+

+  -- Look through nospec, noinline and lazy, which are only eliminated by Core Prep.

+  -- See Note [coreExprAsPmLit and nospec]

+  (Var x, Type _ : inner : rest_args)

+    | x `hasKey` nospecIdKey

+   || x `hasKey` noinlineIdKey

+   || x `hasKey` lazyIdKey

+    -> coreExprAsPmLit (mkApps inner rest_args)

+

+Note [coreExprAsPmLit and nospec]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+For coverage checking, we need to analyse overloaded literal patterns to figure

+out which literals they correspond to; this is what 'coreExprAsPmLit' does.

+For example, the literal pattern "fromString" (with -XOverloadedStrings)

+will turn into an equality check against the **expression**

+

+  fromString @T $dFromString "hello"#

+

+and 'coreExprAsPmLit' recovers the string by taking apart this application.

+

+However, when $dFromString is non-canonical (e.g. when an INCOHERENT

+instance was discarded during resolution of the typeclass constraint, or when

+the dictionary comes from 'withDict'), the desugarer wraps 'fromString' in

+'nospec' (as per Note [nospecId magic] in GHC.Types.Id.Make and

+Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr):

+

+  nospec @(IsString a => String -> Maybe a) fromString @T $dFromString "hello"#

+

+(For a full example, see test case T27124a.)

+

+The 'nospec' mechanism only exists for the specialiser; it should be transparent

+to everything else. 'coreExprAsPmLit' must thus look through the 'nospec'

+application in order obtain the string "hello". If it doesn't, we can't do

+pattern match checking (in fact GHC.HsToCore.Pmc.Desugar.desugarPat is liable

+to crash!).

+

+The same reasoning applies to `noinline` and `lazy`.

+                     -- On Windows, module .o files may be archives (see

+                     -- Note [Object merging] in GHC.Driver.Pipeline.Execute).

+                     -- Use --whole-archive to ensure all archive members are

+                     -- included, especially those containing .ctors/.dtors

+                     -- initializer/finalizer sections. See Note [Initializers and

+                     -- finalizers in Cmm] in GHC.Cmm.InitFini.

+                     ++ (if platformOS platform == OSMinGW32

+                         then ["-Wl,--whole-archive"]

+                         else [])

+                     ++ o_files

+                     ++ (if platformOS platform == OSMinGW32

+                         then ["-Wl,--no-whole-archive"]

+                         else [])

+

+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar EvCanonical err_tm

+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var EvCanonical err_tm

+--

+-- See Note [Finalizers via __cxa_atexit]

+finalizerCStub platform clbl declarations body

+  | ArchWasm32 <- platformArch platform

+  = -- See Note [Finalizers via __cxa_atexit]

+    cxaAtexitFinalizerCStub platform clbl declarations body

+finalizerCStub platform clbl declarations body

+  | OSDarwin <- platformOS platform

+  = -- See Note [Finalizers via __cxa_atexit]

+    cxaAtexitFinalizerCStub platform clbl declarations body

+finalizerCStub platform clbl declarations body

+  = functionCStub platform clbl declarations body

+-- | Generate a @__cxa_atexit@-based finalizer.

+-- See Note [Finalizers via __cxa_atexit]

+cxaAtexitFinalizerCStub :: Platform -> CLabel -> SDoc -> SDoc -> CStub

+cxaAtexitFinalizerCStub platform clbl declarations body =

+    let clbl_pretty = pprCLabel platform clbl

+        fini_name    = hcat [clbl_pretty, text "$fini"]

+        wrapper_name = hcat [clbl_pretty, text "$fini_atexit"]

+        c_code = vcat

+          [ declarations

+          , text "int __cxa_atexit(void (*)(void *), void *, void *);"

+          , hcat [text "static void ", fini_name, text "(void)"]

+          , braces body

+          , hcat [text "static void ", wrapper_name, text "(void *arg __attribute__((unused)))"]

+          , braces (hcat [fini_name, text "();"])

+          , hsep [text "void", clbl_pretty, text "(void)"]

+          , braces (hcat [text "__cxa_atexit(", wrapper_name, text ", 0, 0);"])

+          ]

+    in CStub c_code [clbl] []

+

+{-

+Note [Finalizers via __cxa_atexit]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+On some platforms, placing a function pointer in the .fini_array /

+__mod_term_func section is not sufficient to have it called on exit.

+On these platforms we instead lower finalizers as initializers that register

+the actual finalizer function via __cxa_atexit.

+

+Affected platforms:

+

+  Wasm32: does not support .fini_array sections.

+

+  Darwin: modern macOS dyld no longer processes __DATA,__mod_term_func entries.

+  Clang now lowers __attribute__((destructor)) as an initializer that calls

+  __cxa_atexit, placing the initializer in __DATA,__mod_init_func (which the

+  linker converts to __TEXT,__init_offsets). GHC must follow the same pattern.

+

+For a finalizer with label `clbl` and body `body`, on these platforms we

+generate:

+

+    static void clbl$fini(void) {

+        <body>

+    }

+    static void clbl$fini_atexit(void *arg) {

+        clbl$fini();

+    }

+    void clbl(void) {

+        __cxa_atexit(clbl$fini_atexit, 0, 0);

+    }

+

+The function `clbl` is placed in the initializers list (getInitializers)

+instead of the finalizers list (getFinalizers). During code output,

+emitInitializerDecls places it in .init_array / __mod_init_func, so the

+registration runs at startup.

+

+The actual finalizer body is in the static helper `clbl$fini`. A separate

+wrapper `clbl$fini_atexit` with the void(*)(void*) signature expected by

+__cxa_atexit is needed because some platforms (e.g. wasm32) enforce exact

+function signature matching at call sites — a simple cast would trap at

+runtime.

+

+This matches what clang does when lowering __attribute__((destructor)) on

+these platforms.

+-}

+

+/* Note [Object unloading and finalizers]

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

+ * An ObjectCode may contain .fini_array/.dtors sections with finalizers that

+ * should run when the object is unloaded. However, we must only run these

+ * finalizers if the corresponding initializers (.init_array/.ctors) have

+ * actually been executed.

+ *

+ * Archive members start in OBJECT_LOADED state and only progress to

+ * OBJECT_NEEDED -> OBJECT_RESOLVED -> OBJECT_READY when a symbol from

+ * them is actually required. An archive member that was never needed never

+ * has its relocations applied, so its .fini_array section data still

+ * contains zeros (unresolved relocation targets). Running those finalizers

+ * would dereference NULL function pointers.

+ *

+ * When unloadObj sets an object's status to OBJECT_UNLOADED, it does so

+ * regardless of the previous state, so we cannot rely on the status alone

+ * to decide whether finalizers should run. Instead, we track whether

+ * initializers were executed via the initializersRan flag, which is set in

+ * ocRunInit after successfully running the initializers.

+ */

+

+    // Run finalizers only if initializers have been run.

+    // See Note [Object unloading and finalizers].

+    if (oc->type == STATIC_OBJECT && oc->initializersRan) {

+   oc->initializersRan   = false;

+    oc->initializersRan = true;

+    /* Set to true after initializers (.init_array, .ctors, etc.) have been

+     * executed. Used by freeObjectCode to decide whether finalizers should

+     * run: only objects whose initializers ran should have their finalizers

+     * executed. See Note [Object unloading and finalizers]. */

+    bool initializersRan;

+

+{-# LANGUAGE StaticPointers #-}

+module T27072d where

+

+import GHC.StaticPtr

+

+f :: StaticPtr Int

+f = static 1

+

+g :: StaticPtr Int

+g = static 2

+SPT entries after init: 2

+SPT entries after finalizer: 0

+// Test that GHC-generated module initializers and finalizer registrations

+// work correctly on Darwin.

+//

+// On Darwin, GHC lowers finalizers as __cxa_atexit registrations from an

+// initializer placed in __DATA,__mod_init_func (see Note [Finalizers via

+// __cxa_atexit] in GHC.Types.ForeignStubs).

+//

+// This test verifies the mechanism by checking that:

+//  1. The SPT initializer runs at load time (entries are inserted).

+//  2. The SPT finalizer (registered via __cxa_atexit from __mod_init_func)

+//     fires during exit() and removes the entries.

+//

+// We verify (2) by registering our own __cxa_atexit checker from a

+// constructor in a dylib that is loaded before the main executable's

+// initializers run. Since __cxa_atexit handlers fire in LIFO order,

+// a handler registered earlier runs later — so our checker runs after the

+// GHC-generated finalizer, and can observe that SPT entries were removed.

+//

+// The Apple linker does not support --wrap, so this is the Darwin

+// equivalent of T27072w's approach.

+

+#include "Rts.h"

+#include <stdio.h>

+

+extern int hs_spt_key_count(void);

+

+int main(int argc, char *argv[]) {

+    RtsConfig conf = defaultRtsConfig;

+    conf.rts_opts_enabled = RtsOptsAll;

+    hs_init_ghc(&argc, &argv, conf);

+

+    printf("SPT entries after init: %d\n", hs_spt_key_count());

+    fflush(stdout);

+

+    // Do NOT call hs_exit(). Return normally so __cxa_atexit handlers fire,

+    // which includes the GHC-generated finalizer registered during init.

+    return 0;

+}

+// Checker dylib for T27072d.

+//

+// Compiled as a dylib and linked against the test executable. Because dylib

+// initializers run before the main executable's __mod_init_func entries,

+// our __cxa_atexit registration happens first. Since __cxa_atexit handlers

+// fire in LIFO order, our checker runs *after* the GHC-generated finalizer,

+// allowing us to observe that SPT entries were removed.

+

+#include <stdio.h>

+

+// Provided by the RTS.

+extern int hs_spt_key_count(void);

+

+static void check_spt_finalizer(void *arg __attribute__((unused))) {

+    int count = hs_spt_key_count();

+    printf("SPT entries after finalizer: %d\n", count);

+    fflush(stdout);

+}

+

+// Register the checker. This constructor runs during dylib initialization,

+// which happens before the main executable's initializers.

+__attribute__((constructor))

+static void register_spt_checker(void) {

+    // Use __cxa_atexit so we participate in the same LIFO chain as the

+    // GHC-generated finalizer.

+    extern int __cxa_atexit(void (*)(void *), void *, void *);

+    extern void *__dso_handle;

+    __cxa_atexit(check_spt_finalizer, (void *)0, &__dso_handle);

+}

+{-# LANGUAGE StaticPointers #-}

+module T27072w where

+

+import GHC.StaticPtr

+

+f :: StaticPtr Int

+f = static 1

+

+g :: StaticPtr Int

+g = static 2

+SPT entries after init: 2

+finalizer: hs_spt_remove called

+finalizer: hs_spt_remove called

+// Test that GHC-generated finalizers actually run on wasm32

+//

+// We use --wrap=hs_spt_remove to intercept calls from the GHC-generated

+// finalizer and verify they happen during exit().

+

+#include "Rts.h"

+#include <stdio.h>

+

+extern int hs_spt_key_count(void);

+

+// --wrap=hs_spt_remove: the linker redirects all calls to hs_spt_remove

+// through our wrapper, and provides __real_hs_spt_remove for the original.

+extern void __real_hs_spt_remove(StgWord64 key[2]);

+

+void __wrap_hs_spt_remove(StgWord64 key[2]) {

+    printf("finalizer: hs_spt_remove called\n");

+    fflush(stdout);

+    __real_hs_spt_remove(key);

+}

+

+int main(int argc, char *argv[]) {

+    RtsConfig conf = defaultRtsConfig;

+    conf.rts_opts_enabled = RtsOptsAll;

+    hs_init_ghc(&argc, &argv, conf);

+

+    printf("SPT entries after init: %d\n", hs_spt_key_count());

+    fflush(stdout);

+

+    // Do NOT call hs_exit(). Return normally so exit() fires the

+    // __cxa_atexit registered handlers.

+    return 0;

+}

+

+# Check that GHC-generated finalizers run on Darwin. The Apple linker doesn't

+# support --wrap, so we can't intercept hs_spt_remove directly.  Instead we

+# compile a small checker dylib (T27072d_check.c) whose constructor registers

+# a __cxa_atexit handler *before* the executable's __mod_init_func entries run.

+# LIFO ordering ensures the checker fires after the GHC-generated finalizer,

+# so it can observe that SPT entries were removed.

+# Requires dynamic way so the RTS is a dylib (avoids archive conflicts).

+test('T27072d', [req_c, only_ways(['dyn']), when(not opsys('darwin'), skip),

+     pre_cmd('{compiler} -shared -no-hs-main'

+             ' -optl -undefined -optl dynamic_lookup'

+             ' -o T27072d_check.dylib T27072d_check.c')],

+     compile_and_run,

+     ['T27072d_c.c -no-hs-main'

+      ' -optl -Wl,-needed_library,T27072d_check.dylib -optl -rpath -optl .'])

+# check that finalizers are being run, using --wrap to intercept hs_spt_remove.

+# Skipped on Darwin (Apple linker doesn't support --wrap).

+test('T27072w', [req_c, js_skip, when(opsys('darwin'), skip)],

+     compile_and_run, ['T27072w_c.c -no-hs-main -optl-Wl,--wrap=hs_spt_remove'])

+module T25926 where

+

+f () 0 = ()

+f 'a' _ = ()

+T25926.hs:4:3: warning: [GHC-83865] [-Wdeferred-type-errors (in -Wdefault)]

+    • Couldn't match expected type ‘()’ with actual type ‘Char’

+    • In the pattern: 'a'

+      In an equation for ‘f’: f 'a' _ = ()

+

+{-# LANGUAGE OverloadedStrings #-}

+

+module T27124 where

+

+foo :: [String] -> Bool

+foo "HI" = True

+foo _ = False

+

+main = pure ()

+T27124.hs:6:5: warning: [GHC-18872] [-Wdeferred-type-errors (in -Wdefault)]

+    • Couldn't match type ‘[Char]’ with ‘Char’

+        arising from the literal ‘"HI"’

+    • In the pattern: "HI"

+      In an equation for ‘foo’: foo "HI" = True

+

+test('T25926', normal, compile, ['-fdefer-type-errors'])

+test('T27124', normal, compile, ['-fdefer-type-errors'])

+{-# LANGUAGE FlexibleInstances #-}

+{-# LANGUAGE OverloadedStrings #-}

+

+module T27124a where

+

+import Data.String (IsString(..))

+

+newtype Wrap a = Wrap a deriving (Eq, Show)

+

+instance IsString a => IsString (Wrap a) where

+  fromString = Wrap . fromString

+

+instance {-# INCOHERENT #-} IsString (Wrap Bool) where

+  fromString _ = Wrap False

+

+f :: (Eq a, IsString a) => Wrap a -> Bool

+f "hello" = True

+f _       = False

+

+main :: IO ()

+main = do

+  print (f (Wrap ("hello" :: String)))

+  print (f (Wrap ("world" :: String)))

+test('T27124a', normal, compile, ['-fno-specialise-incoherents'])

+// Minimal module with an initializer and finalizer.

+// The compiler places the function pointers in .init_array/.fini_array

+// (ELF) or __mod_init_func/__mod_term_func (Mach-O).

+//

+// The counter lives in the main binary so it survives after this

+// object is unloaded.

+

+extern int init_counter;

+

+__attribute__((constructor))

+static void lib_init(void) {

+    init_counter++;

+}

+

+__attribute__((destructor))

+static void lib_fini(void) {

+    init_counter--;

+}

+.PHONY: clean_build_and_run build_and_run clean build

+

+clean_build_and_run:

+	$(MAKE) clean

+	$(MAKE) build_and_run

+

+build_and_run: build

+	./main

+

+clean:

+	$(RM) Lib.o main.o main

+

+build: Lib.o main

+

+Lib.o: Lib.c

+	$(CC) -c -fPIC Lib.c -o Lib.o

+

+main: main.c

+	"$(TEST_HC)" $(filter-out -rtsopts, $(TEST_HC_OPTS)) \

+		-no-hs-main -optc-Werror \

+		main.c -o main

+counter before load: 0

+counter after load: 1

+counter after unload: 0

+test('T27072',

+     [req_rts_linker,

+      js_skip,

+      extra_files(['Lib.c', 'main.c'])],

+     makefile_test,

+     ['clean_build_and_run'])

+// Test that the RTS linker executes .init_array entries on load and

+// .fini_array entries on unload.  The loaded module increments a

+// counter in its initializer and decrements it in its finalizer.

+

+#include "Rts.h"

+#include <stdio.h>

+

+#if defined(mingw32_HOST_OS)

+#define PATH_STR(str) L##str

+#else

+#define PATH_STR(str) str

+#endif

+

+int init_counter = 0;

+

+int main(int argc, char *argv[]) {

+    RtsConfig conf = defaultRtsConfig;

+    conf.rts_opts_enabled = RtsOptsAll;

+    hs_init_ghc(&argc, &argv, conf);

+

+    initLinker_(0);

+    insertSymbol(PATH_STR("main"), "init_counter", &init_counter);

+

+    printf("counter before load: %d\n", init_counter);

+    fflush(stdout);

+

+    int ok;

+    ok = loadObj(PATH_STR("Lib.o"));

+    if (!ok) {

+        errorBelch("loadObj(Lib.o) failed");

+        return 1;

+    }

+    ok = resolveObjs();

+    if (!ok) {

+        errorBelch("resolveObjs() failed");

+        return 1;

+    }

+

+    printf("counter after load: %d\n", init_counter);

+    fflush(stdout);

+

+    ok = unloadObj(PATH_STR("Lib.o"));

+    if (!ok) {

+        errorBelch("unloadObj(Lib.o) failed");

+        return 1;

+    }

+

+    // GC triggers actual unloading and finalizer execution.

+    performMajorGC();

+    performMajorGC();

+

+    printf("counter after unload: %d\n", init_counter);

+    fflush(stdout);

+

+    hs_exit();

+    return 0;

+}