summaryrefslogtreecommitdiff
path: root/libraries
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2015-11-19 17:58:37 +0100
committerBen Gamari <ben@smart-cactus.org>2015-11-20 16:49:27 +0100
commit7e6dcf482addcba89f2835e55e41720881cb10a4 (patch)
treeba2107b4f383f03e2314aa613b746ebc6b8f667b /libraries
parent998c371b62d31499c95bb8ea3967c44d2ee23e90 (diff)
downloadhaskell-7e6dcf482addcba89f2835e55e41720881cb10a4.tar.gz
base: Delete errant GHC/Stack.hsc
This was added in 8988be8561ce0857f3befd6ab3b6c29060685c0a, probably due to an incorrect merge resolution. The build system has been building `Stack.hs`.
Diffstat (limited to 'libraries')
-rw-r--r--libraries/base/GHC/Stack.hs2
-rw-r--r--libraries/base/GHC/Stack.hsc132
2 files changed, 1 insertions, 133 deletions
diff --git a/libraries/base/GHC/Stack.hs b/libraries/base/GHC/Stack.hs
index d1dd596ca6..f6fe41f06f 100644
--- a/libraries/base/GHC/Stack.hs
+++ b/libraries/base/GHC/Stack.hs
@@ -15,7 +15,7 @@
-- @since 4.5.0.0
-----------------------------------------------------------------------------
-{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash, NoImplicitPrelude #-}
module GHC.Stack (
-- * Call stacks
currentCallStack,
diff --git a/libraries/base/GHC/Stack.hsc b/libraries/base/GHC/Stack.hsc
deleted file mode 100644
index c544721e63..0000000000
--- a/libraries/base/GHC/Stack.hsc
+++ /dev/null
@@ -1,132 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-
------------------------------------------------------------------------------
--- |
--- Module : GHC.Stack
--- Copyright : (c) The University of Glasgow 2011
--- License : see libraries/base/LICENSE
---
--- Maintainer : cvs-ghc@haskell.org
--- Stability : internal
--- Portability : non-portable (GHC Extensions)
---
--- Access to GHC's call-stack simulation
---
--- @since 4.5.0.0
------------------------------------------------------------------------------
-
-{-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
-module GHC.Stack (
- -- * Call stacks
- currentCallStack,
- whoCreated,
- errorWithStackTrace,
-
- -- * Implicit parameter call stacks
- SrcLoc(..), CallStack(..),
-
- -- * Internals
- CostCentreStack,
- CostCentre,
- getCurrentCCS,
- getCCSOf,
- ccsCC,
- ccsParent,
- ccLabel,
- ccModule,
- ccSrcSpan,
- ccsToStrings,
- renderStack
- ) where
-
-import Foreign
-import Foreign.C
-
-import GHC.IO
-import GHC.Base
-import GHC.Ptr
-import GHC.Foreign as GHC
-import GHC.IO.Encoding
-import GHC.List ( concatMap, null, reverse )
-
-#define PROFILING
-#include "Rts.h"
-
-data CostCentreStack
-data CostCentre
-
-getCurrentCCS :: dummy -> IO (Ptr CostCentreStack)
-getCurrentCCS dummy = IO $ \s ->
- case getCurrentCCS## dummy s of
- (## s', addr ##) -> (## s', Ptr addr ##)
-
-getCCSOf :: a -> IO (Ptr CostCentreStack)
-getCCSOf obj = IO $ \s ->
- case getCCSOf## obj s of
- (## s', addr ##) -> (## s', Ptr addr ##)
-
-ccsCC :: Ptr CostCentreStack -> IO (Ptr CostCentre)
-ccsCC p = (# peek CostCentreStack, cc) p
-
-ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
-ccsParent p = (# peek CostCentreStack, prevStack) p
-
-ccLabel :: Ptr CostCentre -> IO CString
-ccLabel p = (# peek CostCentre, label) p
-
-ccModule :: Ptr CostCentre -> IO CString
-ccModule p = (# peek CostCentre, module) p
-
-ccSrcSpan :: Ptr CostCentre -> IO CString
-ccSrcSpan p = (# peek CostCentre, srcloc) p
-
--- | returns a '[String]' representing the current call stack. This
--- can be useful for debugging.
---
--- The implementation uses the call-stack simulation maintined by the
--- profiler, so it only works if the program was compiled with @-prof@
--- and contains suitable SCC annotations (e.g. by using @-fprof-auto@).
--- Otherwise, the list returned is likely to be empty or
--- uninformative.
---
--- @since 4.5.0.0
-
-currentCallStack :: IO [String]
-currentCallStack = ccsToStrings =<< getCurrentCCS ()
-
-ccsToStrings :: Ptr CostCentreStack -> IO [String]
-ccsToStrings ccs0 = go ccs0 []
- where
- go ccs acc
- | ccs == nullPtr = return acc
- | otherwise = do
- cc <- ccsCC ccs
- lbl <- GHC.peekCString utf8 =<< ccLabel cc
- mdl <- GHC.peekCString utf8 =<< ccModule cc
- loc <- GHC.peekCString utf8 =<< ccSrcSpan cc
- parent <- ccsParent ccs
- if (mdl == "MAIN" && lbl == "MAIN")
- then return acc
- else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
-
--- | Get the stack trace attached to an object.
---
--- @since 4.5.0.0
-whoCreated :: a -> IO [String]
-whoCreated obj = do
- ccs <- getCCSOf obj
- ccsToStrings ccs
-
-renderStack :: [String] -> String
-renderStack strs = "Stack trace:" ++ concatMap ("\n "++) (reverse strs)
-
--- | Like the function 'error', but appends a stack trace to the error
--- message if one is available.
---
--- @since 4.7.0.0
-errorWithStackTrace :: String -> a
-errorWithStackTrace x = unsafeDupablePerformIO $ do
- stack <- ccsToStrings =<< getCurrentCCS x
- if null stack
- then throwIO (ErrorCall x)
- else throwIO (ErrorCallWithLocation x (renderStack stack))