3 files changed, 33 insertions, 0 deletions
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index a6c1083834..88938e2ee2 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -49,6 +49,7 @@ module Control.Exception (
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
         AllocationLimitExceeded(..),
+        CompactionFailed(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs
index 9dd96488bc..3e7ac0f9e8 100644
--- a/libraries/base/Control/Exception/Base.hs
+++ b/libraries/base/Control/Exception/Base.hs
@@ -32,6 +32,7 @@ module Control.Exception.Base (
         BlockedIndefinitelyOnMVar(..),
         BlockedIndefinitelyOnSTM(..),
         AllocationLimitExceeded(..),
+        CompactionFailed(..),
         Deadlock(..),
         NoMethodError(..),
         PatternMatchFail(..),
diff --git a/libraries/base/GHC/IO/Exception.hs b/libraries/base/GHC/IO/Exception.hs
index 69d2c330c9..a8d63d3b28 100644
--- a/libraries/base/GHC/IO/Exception.hs
+++ b/libraries/base/GHC/IO/Exception.hs
@@ -24,6 +24,8 @@ module GHC.IO.Exception (
   Deadlock(..),
   AllocationLimitExceeded(..), allocationLimitExceeded,
   AssertionFailed(..),
+  CompactionFailed(..),
+  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,
 
   SomeAsyncException(..),
   asyncExceptionToException, asyncExceptionFromException,
@@ -127,6 +129,35 @@ allocationLimitExceeded = toException AllocationLimitExceeded
 
 -----
 
+-- |Compaction found an object that cannot be compacted.  Functions
+-- cannot be compacted, nor can mutable objects or pinned objects.
+-- See 'Data.Compact.compact'.
+--
+-- @since 4.10.0.0
+data CompactionFailed = CompactionFailed String
+
+-- | @since 4.10.0.0
+instance Exception CompactionFailed where
+
+-- | @since 4.10.0.0
+instance Show CompactionFailed where
+    showsPrec _ (CompactionFailed why) =
+      showString ("compaction failed: " ++ why)
+
+cannotCompactFunction :: SomeException -- for the RTS
+cannotCompactFunction =
+  toException (CompactionFailed "cannot compact functions")
+
+cannotCompactPinned :: SomeException -- for the RTS
+cannotCompactPinned =
+  toException (CompactionFailed "cannot compact pinned objects")
+
+cannotCompactMutable :: SomeException -- for the RTS
+cannotCompactMutable =
+  toException (CompactionFailed "cannot compact mutable objects")
+
+-----
+
 -- |'assert' was applied to 'False'.
 newtype AssertionFailed = AssertionFailed String