compiler: Rework handling of mutator abortingwip/T22038

Previously `-dtag-inference-checks`, `-dcheck-prim-bounds`, and
`-falignment-sanitization` all aborted by calling `barf` from the
mutator. However, this can lead to deadlocks in the threaded RTS. For
instance, in the case of `-dcheck-prim-bounds` the following can happen

1. the mutator takes a capability and begins execution
2. the bounds check fails, calling `barf`
3. `barf` calls `rtsFatalInternalErrorFn`, which in turn calls `endEventLogging`
4. `endEventLogging` calls `flushEventLog`, which it turn initiates a
   sync to request that all capabilities flush their local event logs
5. we deadlock as the the capability held by the crashing mutator can
   never join the sync

To avoid this we now have a more principled means of aborting: we return
to the scheduler setting the thread's return value to ThreadAborting.
The scheduler will see this and call `barf`.

Fixes #22038.

4 files changed, 15 insertions, 13 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c12ecff5eb..5b9c10fc38 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -64,6 +64,7 @@ module GHC.Cmm.CLabel (
         mkSMAP_FROZEN_DIRTY_infoLabel,
         mkSMAP_DIRTY_infoLabel,
         mkBadAlignmentLabel,
+        mkTagInferenceCheckFailureLabel,
         mkOutOfBoundsAccessLabel,
         mkArrWords_infoLabel,
         mkSRTInfoLabel,
@@ -637,8 +638,9 @@ mkDirty_MUT_VAR_Label,
     mkTopTickyCtrLabel,
     mkCAFBlackHoleInfoTableLabel,
     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
-    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,
-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel
+    mkSMAP_DIRTY_infoLabel, mkMUT_VAR_CLEAN_infoLabel,
+    mkBadAlignmentLabel, mkTagInferenceCheckFailureLabel, mkOutOfBoundsAccessLabel
+    :: CLabel
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
@@ -655,9 +657,10 @@ mkArrWords_infoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsL
 mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
 mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
 mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
-mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry
-mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction
-mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo
+mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")            CmmInfo
+mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")             CmmPrimCall
+mkOutOfBoundsAccessLabel        = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_outOfBoundsAccess")        CmmPrimCall
+mkTagInferenceCheckFailureLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_tagInferenceCheckFailure") CmmPrimCall
 
 mkSRTInfoLabel :: Int -> CLabel
 mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 1d482b0143..a044b7076f 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -3211,7 +3211,7 @@ doBoundsCheck idx sz = do
     when do_bounds_check (doCheck platform)
   where
     doCheck platform = do
-        boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+        boundsCheckFailed <- getCode $ emitCall (NativeNodeCall, NativeReturn) (mkLblExpr mkOutOfBoundsAccessLabel) [idx, sz]
         emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
       where
         uGE = cmmUGeWord platform
diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs
index afa3fef426..d41bc356fb 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ b/compiler/GHC/StgToCmm/TagCheck.hs
@@ -19,9 +19,13 @@ import GHC.Prelude
 import GHC.StgToCmm.Env
 import GHC.StgToCmm.Monad
 import GHC.StgToCmm.Utils
+import GHC.StgToCmm.Layout (emitCall)
+import GHC.StgToCmm.Lit (newStringCLit)
 import GHC.Cmm
 import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel (mkTagInferenceCheckFailureLabel)
 import GHC.Cmm.Graph as CmmGraph
+import GHC.Cmm.Utils
 
 import GHC.Core.Type
 import GHC.Types.Id
@@ -95,7 +99,8 @@ emitTagAssertion onWhat fun = do
   ; needsArgTag fun lbarf lret
 
   ; emitLabel lbarf
-  ; emitBarf ("Tag inference failed on:" ++ onWhat)
+  ; onWhat_str <- newStringCLit onWhat
+  ; _ <- emitCall (NativeNodeCall, NativeReturn) (mkLblExpr mkTagInferenceCheckFailureLabel) [CmmLit onWhat_str]
   ; emitLabel lret
   }
 
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
index ddda97ab2a..0656d6f971 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ b/compiler/GHC/StgToCmm/Utils.hs
@@ -12,7 +12,6 @@ module GHC.StgToCmm.Utils (
         emitDataLits, emitRODataLits,
         emitDataCon,
         emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
-        emitBarf,
         assignTemp, newTemp,
 
         newUnboxedTupleRegs,
@@ -158,11 +157,6 @@ tagToClosure platform tycon tag
 --
 -------------------------------------------------------------------------
 
-emitBarf :: String -> FCode ()
-emitBarf msg = do
-  strLbl <- newStringCLit msg
-  emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False
-
 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun)