Fix unboxed-sums GC ptr-slot rubbish value (#17791)

This patch allows boot libraries to use unboxed sums without implicitly
depending on `base` package because of `absentSumFieldError`.

See updated Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make

14 files changed, 135 insertions, 42 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index 52d5bf0fa2..14cfc22cc1 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -511,7 +511,7 @@ genericTyConNames = [
 pRELUDE :: Module
 pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
-gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
+gHC_PRIM, gHC_PRIM_PANIC, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,
     gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
     gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
@@ -527,6 +527,7 @@ gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module
 
 gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values
+gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")
 gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")
 gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")
 gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")
diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 38710f3829..5992bcc4f5 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -735,6 +735,7 @@ errorIds
       rEC_CON_ERROR_ID,
       rEC_SEL_ERROR_ID,
       aBSENT_ERROR_ID,
+      aBSENT_SUM_FIELD_ERROR_ID,
       tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284
       ]
 
@@ -746,8 +747,6 @@ absentSumFieldErrorName :: Name
 
 recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID
 absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID
-absentSumFieldErrorName = err_nm "absentSumFieldError"  absentSumFieldErrorIdKey
-                            aBSENT_SUM_FIELD_ERROR_ID
 runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID
 recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID
 patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID
@@ -774,25 +773,68 @@ tYPE_ERROR_ID                   = mkRuntimeErrorId typeErrorName
 
 -- Note [aBSENT_SUM_FIELD_ERROR_ID]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Absent argument error for unused unboxed sum fields are different than absent
--- error used in dummy worker functions (see `mkAbsentErrorApp`):
 --
--- - `absentSumFieldError` can't take arguments because it's used in unarise for
---   unused pointer fields in unboxed sums, and applying an argument would
---   require allocating a thunk.
+-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum
+-- and fields that can't be reached are filled with rubbish values. It's easy to
+-- come up with rubbish literal values: we use 0 (ints/words) and 0.0
+-- (floats/doubles). Coming up with a rubbish pointer value is more delicate:
 --
--- - `absentSumFieldError` can't be CAFFY because that would mean making some
---   non-CAFFY definitions that use unboxed sums CAFFY in unarise.
+--    1. it needs to be a valid closure pointer for the GC (not a NULL pointer)
 --
---   To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in
---   RtsStartup.c and mark it as non-CAFFY here.
+--    2. it is never used in Core, only in STG; and even then only for filling a
+--       GC-ptr slot in an unboxed sum (see GHC.Stg.Unarise.ubxSumRubbishArg).
+--       So all we need is a pointer, and its levity doesn't matter. Hence we
+--       can safely give it the (lifted) type:
 --
--- Getting this wrong causes hard-to-debug runtime issues, see #15038.
+--             absentSumFieldError :: forall a. a
 --
--- TODO: Remove stable pointer hack after fixing #9718.
---       However, we should still be careful about not making things CAFFY just
---       because they use unboxed sums. Unboxed objects are supposed to be
---       efficient, and none of the other unboxed literals make things CAFFY.
+--       despite the fact that Unarise might instantiate it at non-lifted
+--       types.
+--
+--    3. it can't take arguments because it's used in unarise and applying an
+--       argument would require allocating a thunk.
+--
+--    4. it can't be CAFFY because that would mean making some non-CAFFY
+--       definitions that use unboxed sums CAFFY in unarise.
+--
+--       Getting this wrong causes hard-to-debug runtime issues, see #15038.
+--
+--    5. it can't be defined in `base` package.
+--
+--       Defining `absentSumFieldError` in `base` package introduces a
+--       dependency on `base` for any code using unboxed sums. It became an
+--       issue when we wanted to use unboxed sums in boot libraries used by
+--       `base`, see #17791.
+--
+--
+-- * Most runtime-error functions throw a proper Haskell exception, which can be
+--   caught in the usual way. But these functions are defined in
+--   `base:Control.Exception.Base`, hence, they cannot be directly invoked in
+--   any library compiled before `base`.  Only exceptions that have been wired
+--   in the RTS can be thrown (indirectly, via a call into the RTS) by libraries
+--   compiled before `base`.
+--
+--   However wiring exceptions in the RTS is a bit annoying because we need to
+--   explicitly import exception closures via their mangled symbol name (e.g.
+--   `import CLOSURE base_GHCziIOziException_heapOverflow_closure`) in Cmm files
+--   and every imported symbol must be indicated to the linker in a few files
+--   (`package.conf`, `rts.cabal`, `win32/libHSbase.def`, `Prelude.h`...). It
+--   explains why exceptions are only wired in the RTS when necessary.
+--
+-- * `absentSumFieldError` is defined in ghc-prim:GHC.Prim.Panic, hence, it can
+--   be invoked in libraries compiled before `base`. It does not throw a Haskell
+--   exception; instead, it calls `stg_panic#`, which immediately halts
+--   execution.  A runtime invocation of `absentSumFieldError` indicates a GHC
+--   bug. Unlike (say) pattern-match errors, it cannot be caused by a user
+--   error. That's why it is OK for it to be un-catchable.
+--
+
+absentSumFieldErrorName
+   = mkWiredInIdName
+      gHC_PRIM_PANIC
+      (fsLit "absentSumFieldError")
+      absentSumFieldErrorIdKey
+      aBSENT_SUM_FIELD_ERROR_ID
 
 aBSENT_SUM_FIELD_ERROR_ID
   = mkVanillaGlobalWithInfo absentSumFieldErrorName
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
index e0b96d0249..da2b06809e 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ b/compiler/GHC/Stg/Unarise.hs
@@ -577,18 +577,26 @@ mkUbxSum dc ty_args args0
         | Just stg_arg <- IM.lookup arg_idx arg_map
         = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
         | otherwise
-        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
-
-      slotRubbishArg :: SlotTy -> StgArg
-      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
-                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
-      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
-      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
-      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
-      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+        = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
     in
       tag_arg : mkTupArgs 0 sum_slots arg_idxs
 
+
+-- | Return a rubbish value for the given slot type.
+--
+-- We use the following rubbish values:
+--    * Literals: 0 or 0.0
+--    * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
+--
+-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
+--
+ubxSumRubbishArg :: SlotTy -> StgArg
+ubxSumRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+ubxSumRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
+ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
+ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+
 --------------------------------------------------------------------------------
 
 {-
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 7918cf4e01..dc2b0715ca 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -418,6 +418,7 @@ RTS_FUN_DECL(stg_raiseDivZZerozh);
 RTS_FUN_DECL(stg_raiseUnderflowzh);
 RTS_FUN_DECL(stg_raiseOverflowzh);
 RTS_FUN_DECL(stg_raiseIOzh);
+RTS_FUN_DECL(stg_paniczh);
 
 RTS_FUN_DECL(stg_makeStableNamezh);
 RTS_FUN_DECL(stg_makeStablePtrzh);
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index f15dc0590d..a009004879 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -95,7 +95,7 @@ module Control.Exception.Base (
         -- * Calls for GHC runtime
         recSelError, recConError, runtimeError,
         nonExhaustiveGuardsError, patError, noMethodBindingError,
-        absentError, absentSumFieldError, typeError,
+        absentError, typeError,
         nonTermination, nestedAtomically,
   ) where
 
@@ -398,7 +398,3 @@ nonTermination = toException NonTermination
 -- GHC's RTS calls this
 nestedAtomically :: SomeException
 nestedAtomically = toException NestedAtomically
-
--- Introduced by unarise for unused unboxed sum fields
-absentSumFieldError :: a
-absentSumFieldError = absentError " in unboxed sum."#
diff --git a/libraries/ghc-prim/GHC/Prim/Panic.hs b/libraries/ghc-prim/GHC/Prim/Panic.hs
new file mode 100644
index 0000000000..8dd8f03530
--- /dev/null
+++ b/libraries/ghc-prim/GHC/Prim/Panic.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE EmptyCase #-}
+
+-- | Primitive panics.
+module GHC.Prim.Panic
+   ( absentSumFieldError
+   , panicError
+   )
+where
+
+import GHC.Prim
+import GHC.Magic
+
+default () -- Double and Integer aren't available yet
+
+-- `stg_panic#` never returns but it can't just return `State# RealWorld` so we
+-- indicate that it returns `Void#` too to make the compiler happy.
+foreign import prim "stg_paniczh" panic# :: Addr# -> State# RealWorld -> (# State# RealWorld, Void# #)
+
+-- | Display the CString whose address is given as an argument and exit.
+panicError :: Addr# -> a
+panicError errmsg =
+  runRW# (\s ->
+    case panic# errmsg s of
+      (# _, _ #) -> -- This bottom is unreachable but we can't
+                    -- use an empty case lest the pattern match
+                    -- checker squawks.
+                    let x = x in x)
+
+-- | Closure introduced by GHC.Stg.Unarise for unused unboxed sum fields.
+--
+-- See Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make
+absentSumFieldError :: a
+absentSumFieldError = panicError "entered absent sum field!"#
+
+-- GHC.Core.Make.aBSENT_SUM_FIELD_ERROR_ID gives absentSumFieldError a bottoming
+-- demand signature. But if we ever inlined it (to a call to panicError) we'd
+-- lose that information.  Should not happen because absentSumFieldError is only
+-- introduced in Stg.Unarise, long after inlining has stopped, but it seems
+-- more direct simply to give it a NOINLINE pragma
+{-# NOINLINE absentSumFieldError #-}
diff --git a/libraries/ghc-prim/ghc-prim.cabal b/libraries/ghc-prim/ghc-prim.cabal
index 040eb43b27..607f24df99 100644
--- a/libraries/ghc-prim/ghc-prim.cabal
+++ b/libraries/ghc-prim/ghc-prim.cabal
@@ -46,6 +46,7 @@ Library
         GHC.IntWord64
         GHC.Magic
         GHC.Prim.Ext
+        GHC.Prim.Panic
         GHC.PrimopWrappers
         GHC.Tuple
         GHC.Types
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 726489e191..587708e47e 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -632,3 +632,12 @@ stg_raiseIOzh (P_ exception)
 {
     jump stg_raisezh (exception);
 }
+
+/* The FFI doesn't support variadic C functions so we can't directly expose
+ * `barf` to Haskell code. Instead we define "stg_panic#" and it is exposed to
+ * Haskell programs in GHC.Prim.Panic.
+ */
+stg_paniczh (W_ str)
+{
+    ccall barf(str) never returns;
+}
diff --git a/rts/Prelude.h b/rts/Prelude.h
index 7bcb6292fa..c6971677af 100644
--- a/rts/Prelude.h
+++ b/rts/Prelude.h
@@ -45,7 +45,6 @@ PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactPinned_closure);
 PRELUDE_CLOSURE(base_GHCziIOziException_cannotCompactMutable_closure);
 PRELUDE_CLOSURE(base_ControlziExceptionziBase_nonTermination_closure);
 PRELUDE_CLOSURE(base_ControlziExceptionziBase_nestedAtomically_closure);
-PRELUDE_CLOSURE(base_ControlziExceptionziBase_absentSumFieldError_closure);
 PRELUDE_CLOSURE(base_GHCziEventziThread_blockedOnBadFD_closure);
 PRELUDE_CLOSURE(base_GHCziExceptionziType_divZZeroException_closure);
 PRELUDE_CLOSURE(base_GHCziExceptionziType_underflowException_closure);
@@ -103,7 +102,6 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_con_info);
 #define nonTermination_closure    DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nonTermination_closure)
 #define nestedAtomically_closure  DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_nestedAtomically_closure)
 #define blockedOnBadFD_closure    DLL_IMPORT_DATA_REF(base_GHCziEventziThread_blockedOnBadFD_closure)
-#define absentSumFieldError_closure DLL_IMPORT_DATA_REF(base_ControlziExceptionziBase_absentSumFieldError_closure)
 
 #define Czh_con_info              DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_Czh_con_info)
 #define Izh_con_info              DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_Izh_con_info)
diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c
index 6e8bed1255..a628a8633b 100644
--- a/rts/RtsStartup.c
+++ b/rts/RtsStartup.c
@@ -275,10 +275,6 @@ hs_init_ghc(int *argc, char **argv[], RtsConfig rts_config)
     getStablePtr((StgPtr)cannotCompactPinned_closure);
     getStablePtr((StgPtr)cannotCompactMutable_closure);
     getStablePtr((StgPtr)nestedAtomically_closure);
-    getStablePtr((StgPtr)absentSumFieldError_closure);
-        // `Id` for this closure is marked as non-CAFFY,
-        // see Note [aBSENT_SUM_FIELD_ERROR_ID] in GHC.Core.Make.
-
     getStablePtr((StgPtr)runSparks_closure);
     getStablePtr((StgPtr)ensureIOManagerIsRunning_closure);
     getStablePtr((StgPtr)ioManagerCapabilitiesChanged_closure);
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index c62810b4d3..7e89aaffc5 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -732,6 +732,7 @@
       SymI_HasProto(stg_raiseUnderflowzh)                               \
       SymI_HasProto(stg_raiseOverflowzh)                                \
       SymI_HasProto(stg_raiseIOzh)                                      \
+      SymI_HasProto(stg_paniczh)                                        \
       SymI_HasProto(stg_readTVarzh)                                     \
       SymI_HasProto(stg_readTVarIOzh)                                   \
       SymI_HasProto(resumeThread)                                       \
diff --git a/rts/package.conf.in b/rts/package.conf.in
index c13e20119a..4c7a2a9b8f 100644
--- a/rts/package.conf.in
+++ b/rts/package.conf.in
@@ -97,7 +97,6 @@ ld-options:
          , "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure"
          , "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure"
          , "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure"
-         , "-Wl,-u,_base_ControlziExceptionziBase_absentSumFieldError_closure"
          , "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
          , "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure"
@@ -203,7 +202,6 @@ ld-options:
          , "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure"
          , "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure"
          , "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure"
-         , "-Wl,-u,base_ControlziExceptionziBase_absentSumFieldError_closure"
          , "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
          , "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
          , "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure"
diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in
index b9a67c7ca1..615260efd8 100644
--- a/rts/rts.cabal.in
+++ b/rts/rts.cabal.in
@@ -218,7 +218,6 @@ library
          "-Wl,-u,_base_GHCziIOziException_cannotCompactFunction_closure"
          "-Wl,-u,_base_GHCziIOziException_cannotCompactPinned_closure"
          "-Wl,-u,_base_GHCziIOziException_cannotCompactMutable_closure"
-         "-Wl,-u,_base_ControlziExceptionziBase_absentSumFieldError_closure"
          "-Wl,-u,_base_ControlziExceptionziBase_nonTermination_closure"
          "-Wl,-u,_base_ControlziExceptionziBase_nestedAtomically_closure"
          "-Wl,-u,_base_GHCziEventziThread_blockedOnBadFD_closure"
@@ -294,7 +293,6 @@ library
          "-Wl,-u,base_GHCziIOziException_cannotCompactFunction_closure"
          "-Wl,-u,base_GHCziIOziException_cannotCompactPinned_closure"
          "-Wl,-u,base_GHCziIOziException_cannotCompactMutable_closure"
-         "-Wl,-u,base_ControlziExceptionziBase_absentSumFieldError_closure"
          "-Wl,-u,base_ControlziExceptionziBase_nonTermination_closure"
          "-Wl,-u,base_ControlziExceptionziBase_nestedAtomically_closure"
          "-Wl,-u,base_GHCziEventziThread_blockedOnBadFD_closure"
diff --git a/rts/win32/libHSbase.def b/rts/win32/libHSbase.def
index 0b674452a1..de4db2244b 100644
--- a/rts/win32/libHSbase.def
+++ b/rts/win32/libHSbase.def
@@ -42,7 +42,6 @@ EXPORTS
         base_GHCziIOziException_cannotCompactPinned_closure
         base_GHCziIOziException_cannotCompactMutable_closure
 
-	base_ControlziExceptionziBase_absentSumFieldError_closure
 	base_ControlziExceptionziBase_nonTermination_closure
 	base_ControlziExceptionziBase_nestedAtomically_closure
 	base_GHCziEventziThread_blockedOnBadFD_closure