1 files changed, 45 insertions, 1 deletions
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index 0b16fba72d..687ced2f47 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -1,6 +1,14 @@
 -- (c) The University of Glasgow 2006
 
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE BangPatterns #-}
+#if __GLASGOW_HASKELL__ < 800
+-- For CallStack business
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE FlexibleContexts #-}
+#endif
 
 -- | Highly random utility functions
 --
@@ -110,6 +118,12 @@ module Util (
 
         -- * Hashing
         hashString,
+
+        -- * Call stacks
+        GHC.Stack.CallStack,
+        HasCallStack,
+        HasDebugCallStack,
+        prettyCurrentCallStack,
     ) where
 
 #include "HsVersions.h"
@@ -123,6 +137,7 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Data.List        hiding (group)
 
 import GHC.Exts
+import qualified GHC.Stack
 
 import Control.Applicative ( liftA2 )
 import Control.Monad    ( liftM )
@@ -1260,3 +1275,32 @@ mulHi :: Int32 -> Int32 -> Int32
 mulHi a b = fromIntegral (r `shiftR` 32)
    where r :: Int64
          r = fromIntegral a * fromIntegral b
+
+-- | A compatibility wrapper for the @GHC.Stack.HasCallStack@ constraint.
+#if __GLASGOW_HASKELL__ >= 800
+type HasCallStack = GHC.Stack.HasCallStack
+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+-- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
+#else
+type HasCallStack = (() :: Constraint)
+#endif
+
+-- | A call stack constraint, but only when 'isDebugOn'.
+#if DEBUG
+type HasDebugCallStack = HasCallStack
+#else
+type HasDebugCallStack = (() :: Constraint)
+#endif
+
+-- | Pretty-print the current callstack
+#if __GLASGOW_HASKELL__ >= 800
+prettyCurrentCallStack :: HasCallStack => String
+prettyCurrentCallStack = GHC.Stack.prettyCallStack GHC.Stack.callStack
+#elif MIN_VERSION_GLASGOW_HASKELL(7,10,2,0)
+prettyCurrentCallStack :: (?callStack :: GHC.Stack.CallStack) => String
+prettyCurrentCallStack = GHC.Stack.showCallStack ?callStack
+#else
+prettyCurrentCallStack :: HasCallStack => String
+prettyCurrentCallStack = "Call stack unavailable"
+#endif