From: simonpj Date: Thu, 19 May 2005 07:58:36 +0000 (+0000) Subject: [project @ 2005-05-19 07:58:35 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~513 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f7ccc07816e862902d217ec37a6bcff5889b786c;p=ghc-hetmet.git [project @ 2005-05-19 07:58:35 by simonpj] Catch an exception in Template Haskell code Merge to STABLE If the code run by a Template Haskell splice fails with, say, a pattern-match failure, we should not report it as a GHC panic. It's a bug in the user's program. This commit fixes up the exception handling to do the right thing. Fixes SourceForge item #1201666 TH_fail tests it. --- diff --git a/ghc/compiler/nativeGen/MachCodeGen.hs b/ghc/compiler/nativeGen/MachCodeGen.hs index f700fbc..26e86f3 100644 --- a/ghc/compiler/nativeGen/MachCodeGen.hs +++ b/ghc/compiler/nativeGen/MachCodeGen.hs @@ -35,7 +35,6 @@ import ForeignCall ( CCallConv(..) ) import OrdList import Pretty import Outputable -import qualified Outputable import FastString import FastTypes ( isFastTrue ) import Constants ( wORD_SIZE ) diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 12cae9e..61fa199 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -88,7 +88,6 @@ import Cmm import MachOp ( MachRep(..) ) import CLabel ( CLabel, mkMainCapabilityLabel ) -import Unique ( Unique ) import Pretty import Outputable ( Outputable(..), pprPanic, panic ) import qualified Outputable diff --git a/ghc/compiler/nativeGen/RegisterAlloc.hs b/ghc/compiler/nativeGen/RegisterAlloc.hs index 80f32e6..1295f9c 100644 --- a/ghc/compiler/nativeGen/RegisterAlloc.hs +++ b/ghc/compiler/nativeGen/RegisterAlloc.hs @@ -93,7 +93,7 @@ import RegAllocInfo import Cmm import Digraph -import Unique ( Uniquable(..), Unique, getUnique ) +import Unique ( Uniquable(getUnique), Unique ) import UniqSet import UniqFM import Outputable diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 7f9d82b..4b2c7e5 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -376,22 +376,29 @@ runMeta expr ; this_mod <- getModule ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - -- Wrap the compile-and-run in an exception-catcher - -- Compiling might fail if linking fails - -- Running might fail if it throws an exception - ; either_tval <- tryM $ do - { -- Compile it - hval <- ioToTcRn (HscMain.compileExpr + + -- Compile and link it; might fail if linking fails + ; either_hval <- tryM $ ioToTcRn $ + HscMain.compileExpr hsc_env this_mod - rdr_env type_env expr) - -- Coerce it to Q t, and run it - ; TH.runQ (unsafeCoerce# hval) } + rdr_env type_env expr + ; case either_hval of { + Left exn -> failWithTc (mk_msg "compile and link" exn) ; + Right hval -> do + + { -- Coerce it to Q t, and run it + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + either_tval <- tryAllM (TH.runQ (unsafeCoerce# hval)) ; case either_tval of - Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:", - nest 4 (vcat [text "Code:" <+> ppr expr, - text ("Exn: " ++ Panic.showException exn)])]) - Right v -> returnM v } + Left exn -> failWithTc (mk_msg "run" exn) + Right v -> returnM v + }}} + where + mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", + nest 2 (text (Panic.showException exn)), + nest 2 (text "Code:" <+> ppr expr)] \end{code} To call runQ in the Tc monad, we need to make TcM an instance of Quasi: diff --git a/ghc/compiler/utils/IOEnv.hs b/ghc/compiler/utils/IOEnv.hs index 7747e33..6f383b2 100644 --- a/ghc/compiler/utils/IOEnv.hs +++ b/ghc/compiler/utils/IOEnv.hs @@ -7,7 +7,7 @@ module IOEnv ( IOEnv, -- Instance of Monad -- Standard combinators, specialised - returnM, thenM, thenM_, failM, + returnM, thenM, thenM_, failM, failWithM, mappM, mappM_, mapSndM, sequenceM, sequenceM_, foldlM, mapAndUnzipM, mapAndUnzip3M, @@ -17,7 +17,7 @@ module IOEnv ( getEnv, setEnv, updEnv, runIOEnv, unsafeInterleaveM, - tryM, fixM, + tryM, tryAllM, fixM, -- I/O operations ioToIOEnv, @@ -25,12 +25,10 @@ module IOEnv ( ) where #include "HsVersions.h" -import Panic ( tryJust ) +import Panic ( try, tryUser, Exception(..) ) import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) -import EXCEPTION ( Exception(..) ) -import IO ( isUserError ) ---------------------------------------------------------------------- @@ -60,6 +58,9 @@ thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env }) failM :: IOEnv env a failM = IOEnv (\ env -> ioError (userError "IOEnv failure")) +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ env -> ioError (userError s)) + ---------------------------------------------------------------------- @@ -86,19 +87,18 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) --------------------------- tryM :: IOEnv env r -> IOEnv env (Either Exception r) --- Reflect exception into IOEnv envonad -tryM (IOEnv thing) = IOEnv (\ env -> tryJust tc_errors (thing env)) - where -#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500 - tc_errors e@(IOException ioe) | isUserError ioe = Just e -#elif __GLASGOW_HASKELL__ == 502 - tc_errors e@(UserError _) = Just e -#else - tc_errors e@(IOException ioe) | isUserError e = Just e -#endif - tc_errors _other = Nothing - -- type checker failures show up as UserErrors only - +-- Reflect UserError exceptions into IOEnv monad +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env)) + +tryAllM :: IOEnv env r -> IOEnv env (Either Exception r) +-- Catch *all* exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) --------------------------- unsafeInterleaveM :: IOEnv env a -> IOEnv env a diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs index 3766383..6ad720f 100644 --- a/ghc/compiler/utils/Panic.lhs +++ b/ghc/compiler/utils/Panic.lhs @@ -11,13 +11,15 @@ some unnecessary loops in the module dependency graph. \begin{code} module Panic ( - GhcException(..), ghcError, progName, + GhcException(..), showGhcException, ghcError, progName, pgmError, + panic, panic#, assertPanic, trace, - showException, showGhcException, tryMost, - installSignalHandlers, + + Exception.Exception(..), showException, try, tryJust, tryMost, tryUser, + catchJust, ioErrors, throwTo, - catchJust, tryJust, ioErrors, throwTo, + installSignalHandlers, ) where #include "HsVersions.h" @@ -52,6 +54,7 @@ import DYNAMIC import qualified EXCEPTION as Exception import TRACE ( trace ) import UNSAFE_IO ( unsafePerformIO ) +import IO ( isUserError ) import System \end{code} @@ -162,7 +165,7 @@ assertPanic file line = -- files, for example. tryMost :: IO a -> IO (Either Exception.Exception a) -tryMost action = do r <- myTry action; filter r +tryMost action = do r <- try action; filter r where filter (Left e@(Exception.DynException d)) | Just ghc_ex <- fromDynamic d @@ -173,17 +176,32 @@ tryMost action = do r <- myTry action; filter r filter other = return other -#if __GLASGOW_HASKELL__ <= 408 -myTry = Exception.tryAllIO -#else -myTry = Exception.try +-- | 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 +#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500 + tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e +#elif __GLASGOW_HASKELL__ == 502 + tc_errors e@(UserError _) = Just e +#else + tc_errors e@(Exception.IOException ioe) | isUserError e = Just e #endif + tc_errors _other = Nothing \end{code} Compatibility stuff: \begin{code} #if __GLASGOW_HASKELL__ <= 408 +try = Exception.tryAllIO +#else +try = Exception.try +#endif + +#if __GLASGOW_HASKELL__ <= 408 catchJust = Exception.catchIO tryJust = Exception.tryIO ioErrors = Exception.justIoErrors