Panic.lhs 6.67 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP Project, Glasgow University, 1992-2000
4
5
6
7
8
9
10
11
%

Defines basic funtions for printing error messages.

It's hard to put these functions anywhere else without causing
some unnecessary loops in the module dependency graph.

\begin{code}
12
13
module Panic  
   ( 
14
     GhcException(..), showGhcException, ghcError, progName, 
15
     pgmError,
16

sof's avatar
sof committed
17
     panic, panic#, assertPanic, trace,
18
19
20
     
     Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
     catchJust, ioErrors, throwTo,
21

22
     installSignalHandlers, interruptTargetThread
23
   ) where
24

Ian Lynagh's avatar
Ian Lynagh committed
25
26
-- XXX This define is a bit of a hack, and should be done more nicely
#define FAST_STRING_NOT_NEEDED 1
27
28
#include "HsVersions.h"

29
import Config
30
import FastTypes
31

32
#ifndef mingw32_HOST_OS
33
import System.Posix.Signals
34
#endif /* mingw32_HOST_OS */
35

36
37
38
39
#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 603
import GHC.ConsoleHandler
#endif

40
import Control.Exception
41
import Control.Concurrent ( MVar, ThreadId, withMVar, newMVar )
Simon Marlow's avatar
Simon Marlow committed
42
43
44
45
46
47
48
import Data.Dynamic
import qualified Control.Exception as Exception
import Debug.Trace	( trace )
import System.IO.Unsafe	( unsafePerformIO )
import System.IO.Error	( isUserError )
import System.Exit
import System.Environment
49
50
\end{code}

51
52
53
54
GHC's own exception type.

\begin{code}
ghcError :: GhcException -> a
55
ghcError e = Exception.throwDyn e
56

57
58
59
60
61
62
63
64
65
-- error messages all take the form
--
--	<location>: <error>
--
-- If the location is on the command line, or in GHC itself, then 
-- <location>="ghc".  All of the error types below correspond to 
-- a <location> of "ghc", except for ProgramError (where the string is
-- assumed to contain a location already, so we don't print one).

66
data GhcException
sof's avatar
sof committed
67
68
  = PhaseFailed String		-- name of phase 
  		ExitCode	-- an external phase (eg. cpp) failed
69
  | Interrupted			-- someone pressed ^C
70
  | UsageError String		-- prints the short usage msg after the error
71
  | CmdLineError String		-- cmdline prob, but doesn't print usage
72
  | Panic String		-- the `impossible' happened
73
74
  | InstallationError String	-- an installation problem
  | ProgramError String		-- error in the user's code, probably
75
76
  deriving Eq

Ian Lynagh's avatar
Ian Lynagh committed
77
progName :: String
78
79
80
progName = unsafePerformIO (getProgName)
{-# NOINLINE progName #-}

Ian Lynagh's avatar
Ian Lynagh committed
81
short_usage :: String
82
83
short_usage = "Usage: For basic information, try the `--help' option."
   
84
showException :: Exception.Exception -> String
85
-- Show expected dynamic exceptions specially
86
87
88
showException (Exception.DynException d) | Just e <- fromDynamic d 
					 = show (e::GhcException)
showException other_exn	       	 	 = show other_exn
89

90
instance Show GhcException where
91
92
  showsPrec _ e@(ProgramError _) = showGhcException e
  showsPrec _ e = showString progName . showString ": " . showGhcException e
93

Ian Lynagh's avatar
Ian Lynagh committed
94
showGhcException :: GhcException -> String -> String
95
showGhcException (UsageError str)
96
   = showString str . showChar '\n' . showString short_usage
97
showGhcException (PhaseFailed phase code)
sof's avatar
sof committed
98
99
100
101
102
103
104
105
   = showString "phase `" . showString phase . 
     showString "' failed (exitcode = " . shows int_code . 
     showString ")"
  where
    int_code = 
      case code of
        ExitSuccess   -> (0::Int)
	ExitFailure x -> x
106
107
108
109
110
111
112
showGhcException (CmdLineError str)
   = showString str
showGhcException (ProgramError str)
   = showString str
showGhcException (InstallationError str)
   = showString str
showGhcException (Interrupted)
113
   = showString "interrupted"
114
showGhcException (Panic s)
115
116
   = showString ("panic! (the 'impossible' happened)\n"
		 ++ "  (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t"
117
	         ++ s ++ "\n\n"
118
	         ++ "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug\n")
119

Ian Lynagh's avatar
Ian Lynagh committed
120
myMkTyConApp :: TyCon -> [TypeRep] -> TypeRep
ralf's avatar
ralf committed
121
#if __GLASGOW_HASKELL__ < 603
ralf's avatar
ralf committed
122
123
124
125
126
myMkTyConApp = mkAppTy
#else 
myMkTyConApp = mkTyConApp
#endif

Ian Lynagh's avatar
Ian Lynagh committed
127
ghcExceptionTc :: TyCon
128
129
130
ghcExceptionTc = mkTyCon "GhcException"
{-# NOINLINE ghcExceptionTc #-}
instance Typeable GhcException where
ralf's avatar
ralf committed
131
  typeOf _ = myMkTyConApp ghcExceptionTc []
132
133
134
135
\end{code}

Panics and asserts.

136
\begin{code}
137
panic, pgmError :: String -> a
138
panic    x = Exception.throwDyn (Panic x)
139
pgmError x = Exception.throwDyn (ProgramError x)
140

141
--  #-versions because panic can't return an unboxed int, and that's
142
143
144
-- what TAG_ is with GHC at the moment.  Ugh. (Simon)
-- No, man -- Too Beautiful! (Will)

145
146
panic# :: String -> FastInt
panic# s = case (panic s) of () -> _ILIT 0
147
148

assertPanic :: String -> Int -> a
149
assertPanic file line = 
150
  Exception.throw (Exception.AssertionFailed 
151
           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
152
\end{code}
153
154
155
156
157
158

\begin{code}
-- | tryMost is like try, but passes through Interrupted and Panic
-- exceptions.  Used when we want soft failures when reading interface
-- files, for example.

159
tryMost :: IO a -> IO (Either Exception.Exception a)
160
tryMost action = do r <- try action; filter r
161
  where
162
   filter (Left e@(Exception.DynException d))
163
164
	    | Just ghc_ex <- fromDynamic d
		= case ghc_ex of
165
166
		    Interrupted -> Exception.throw e
		    Panic _     -> Exception.throw e
167
168
169
170
		    _other      -> return (Left e)
   filter other 
     = return other

171
172
173
174
175
176
177
178
-- | tryUser is like try, but catches only UserErrors.
-- These are the ones that are thrown by the TcRn monad 
-- to signal an error in the program being compiled
tryUser :: IO a -> IO (Either Exception.Exception a)
tryUser action = tryJust tc_errors action
  where 
	tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
	tc_errors _other = Nothing
179
180
\end{code}	

181
Standard signal handlers for catching ^C, which just throw an
182
183
184
exception in the target thread.  The current target thread is
the thread at the head of the list in the MVar passed to
installSignalHandlers.
185
186
187
188

\begin{code}
installSignalHandlers :: IO ()
installSignalHandlers = do
189
190
  let
      interrupt_exn = Exception.DynException (toDyn Interrupted)
191
192
193
194
195
196

      interrupt = do
	withMVar interruptTargetThread $ \targets ->
	  case targets of
	   [] -> return ()
	   (thread:_) -> throwTo thread interrupt_exn
197
198
  --
#if !defined(mingw32_HOST_OS)
199
200
  installHandler sigQUIT (Catch interrupt) Nothing 
  installHandler sigINT  (Catch interrupt) Nothing
201
202
203
  return ()
#elif __GLASGOW_HASKELL__ >= 603
  -- GHC 6.3+ has support for console events on Windows
204
205
206
207
  -- NOTE: running GHCi under a bash shell for some reason requires
  -- you to press Ctrl-Break rather than Ctrl-C to provoke
  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know
  -- why --SDM 17/12/2004
208
209
210
211
212
  let sig_handler ControlC = interrupt
      sig_handler Break    = interrupt
      sig_handler _        = return ()

  installHandler (Catch sig_handler)
213
  return ()
214
#else
215
  return () -- nothing
216
#endif
217
218
219

{-# NOINLINE interruptTargetThread #-}
interruptTargetThread :: MVar [ThreadId]
220
interruptTargetThread = unsafePerformIO (newMVar [])
221
\end{code}