X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=ef8d98da5ff3269ca708013ff79746cd2801f22c;hb=54ef1c3c9ef6cecd968d5c1ed6ded3a1a201a870;hp=39cb9b55f7354c80a8506445f176c14817a01d78;hpb=7968190992cc1a148524360967afba8e29edf1f0;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 39cb9b5..ef8d98d 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -274,11 +274,14 @@ import qualified Data.List as List
 import Control.Monad
 import System.Exit	( exitWith, ExitCode(..) )
 import System.Time	( ClockTime, getClockTime )
-import Control.Exception as Exception hiding (handle)
+import Exception
 import Data.IORef
 import System.FilePath
 import System.IO
 import System.IO.Error	( try, isDoesNotExistError )
+#if __GLASGOW_HASKELL__ >= 609
+import Data.Typeable (cast)
+#endif
 import Prelude hiding (init)
 
 
@@ -290,33 +293,55 @@ import Prelude hiding (init)
 -- the top level of your program.  The default handlers output the error
 -- message(s) to stderr and exit cleanly.
 defaultErrorHandler :: DynFlags -> IO a -> IO a
-defaultErrorHandler dflags inner = 
+defaultErrorHandler dflags inner =
   -- top-level exception handler: any unrecognised exception is a compiler bug.
+#if __GLASGOW_HASKELL__ < 609
   handle (\exception -> do
-  	   hFlush stdout
-	   case exception of
-		-- an IO exception probably isn't our fault, so don't panic
-		IOException _ ->
-		  fatalErrorMsg dflags (text (show exception))
-		AsyncException StackOverflow ->
-		  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
-		_other ->
-		  fatalErrorMsg dflags (text (show (Panic (show exception))))
-	   exitWith (ExitFailure 1)
+           hFlush stdout
+           case exception of
+                -- an IO exception probably isn't our fault, so don't panic
+                IOException _ ->
+                  fatalErrorMsg dflags (text (show exception))
+                AsyncException StackOverflow ->
+                  fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+                ExitException _ -> throw exception
+                _ ->
+                  fatalErrorMsg dflags (text (show (Panic (show exception))))
+           exitWith (ExitFailure 1)
+         ) $
+#else
+  handle (\(SomeException exception) -> do
+           hFlush stdout
+           case cast exception of
+                -- an IO exception probably isn't our fault, so don't panic
+                Just (ioe :: IOException) ->
+                  fatalErrorMsg dflags (text (show ioe))
+                _ -> case cast exception of
+                     Just StackOverflow ->
+                         fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
+                     _ -> case cast exception of
+                          Just (ex :: ExitCode) -> throw ex
+                          _ ->
+                              fatalErrorMsg dflags
+                                  (text (show (Panic (show exception))))
+           exitWith (ExitFailure 1)
          ) $
+#endif
 
   -- program errors: messages with locations attached.  Sometimes it is
   -- convenient to just throw these as exceptions.
-  handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
-			exitWith (ExitFailure 1)) $
+  handleErrMsg
+            (\em -> do printBagOfErrors dflags (unitBag em)
+                       exitWith (ExitFailure 1)) $
 
   -- error messages propagated as exceptions
-  handleDyn (\dyn -> do
+  handleGhcException
+            (\ge -> do
   		hFlush stdout
-  		case dyn of
+  		case ge of
 		     PhaseFailed _ code -> exitWith code
 		     Interrupted -> exitWith (ExitFailure 1)
-		     _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
+		     _ -> do fatalErrorMsg dflags (text (show ge))
 			     exitWith (ExitFailure 1)
 	    ) $
   inner
@@ -328,13 +353,13 @@ defaultErrorHandler dflags inner =
 defaultCleanupHandler :: DynFlags -> IO a -> IO a
 defaultCleanupHandler dflags inner = 
     -- make sure we clean up after ourselves
-    later (do cleanTempFiles dflags
+    inner `onException`
+          (do cleanTempFiles dflags
               cleanTempDirs dflags
           )
           -- exceptions will be blocked while we clean the temporary files,
           -- so there shouldn't be any difficulty if we receive further
           -- signals.
-    inner
 
 
 -- | Starts a new session.  A session consists of a set of loaded
@@ -401,7 +426,7 @@ guessOutputFile s = modifySession s $ \env ->
         -- we must add the .exe extention unconditionally here, otherwise
         -- when name has an extension of its own, the .exe extension will
         -- not be added by DriverPipeline.exeFileName.  See #2248
-        name_exe = name <.> "exe"
+        name_exe = fmap (<.> "exe") name
 #else
         name_exe = name
 #endif
@@ -454,6 +479,8 @@ guessTarget file (Just phase)
 guessTarget file Nothing
    | isHaskellSrcFilename file
    = return (Target (TargetFile file Nothing) Nothing)
+   | looksLikeModuleName file
+   = return (Target (TargetModule (mkModuleName file)) Nothing)
    | otherwise
    = do exists <- doesFileExist hs_file
 	if exists
@@ -463,7 +490,10 @@ guessTarget file Nothing
 	if exists
 	   then return (Target (TargetFile lhs_file Nothing) Nothing)
 	   else do
-	return (Target (TargetModule (mkModuleName file)) Nothing)
+        throwGhcException
+                 (ProgramError (showSDoc $
+                 text "target" <+> quotes (text file) <+> 
+                 text "is not a module name or a source file"))
      where 
 	 hs_file  = file <.> "hs"
 	 lhs_file = file <.> "lhs"
@@ -994,7 +1024,7 @@ mkModGuts coreModule = ModGuts {
   mg_rules = [],
   mg_binds = cm_binds coreModule,
   mg_foreign = NoStubs,
-  mg_deprecs = NoDeprecs,
+  mg_warns = NoWarnings,
   mg_hpc_info = emptyHpcInfo False,
   mg_modBreaks = emptyModBreaks,
   mg_vect_info = noVectInfo,
@@ -1550,7 +1580,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries (Just mod)
 	(graph, vertex_fn, key_fn) = graphFromEdges' nodes
 	root 
 	  | Just key <- lookup_key HsSrcFile mod, Just v <- key_fn key = v
-	  | otherwise  = throwDyn (ProgramError "module does not exist")
+	  | otherwise  = ghcError (ProgramError "module does not exist")
 
 moduleGraphNodes :: Bool -> [ModSummary]
   -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int)
@@ -1657,7 +1687,8 @@ downsweep :: HscEnv
 		-- in which case there can be repeats
 downsweep hsc_env old_summaries excl_mods allow_dup_roots
    = -- catch error messages and return them
-     handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
+     handleErrMsg
+               (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
        rootSummaries <- mapM getRootSummary roots
        let root_map = mkRootMap rootSummaries
        checkDuplicates root_map
@@ -1674,7 +1705,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
 	   = do exists <- doesFileExist file
 		if exists 
 		    then summariseFile hsc_env old_summaries file mb_phase maybe_buf
-		    else throwDyn $ mkPlainErrMsg noSrcSpan $
+		    else throwErrMsg $ mkPlainErrMsg noSrcSpan $
 			   text "can't find file:" <+> text file
 	getRootSummary (Target (TargetModule modl) maybe_buf)
  	   = do maybe_summary <- summariseModule hsc_env old_summary_map False 
@@ -1781,7 +1812,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf
 	if ms_hs_date old_summary == src_timestamp 
 	   then do -- update the object-file timestamp
         	  obj_timestamp <-
-                    if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- #1205
+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env)) -- bug #1205
                         then getObjTimestamp location False
                         else return Nothing
 		  return old_summary{ ms_obj_date = obj_timestamp }
@@ -1897,7 +1928,6 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
 			-- Drop external-pkg
 			ASSERT(modulePackageId mod /= thisPackage dflags)
 			return Nothing
-		where
 			
 	     err -> noModError dflags loc wanted_mod err
 			-- Not found
@@ -1925,7 +1955,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
 
 	when (mod_name /= wanted_mod) $
-		throwDyn $ mkPlainErrMsg mod_loc $ 
+		throwErrMsg $ mkPlainErrMsg mod_loc $ 
 			      text "File name does not match module name:" 
 			      $$ text "Saw:" <+> quotes (ppr mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -1992,21 +2022,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+  = throwErrMsg $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
 				
 noHsFileErr :: SrcSpan -> String -> a
 noHsFileErr loc path
-  = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+  = throwErrMsg $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
 packageModErr :: ModuleName -> a
 packageModErr mod
-  = throwDyn $ mkPlainErrMsg noSrcSpan $
+  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> text "is a package module"
 
 multiRootsErr :: [ModSummary] -> IO ()
 multiRootsErr [] = panic "multiRootsErr"
 multiRootsErr summs@(summ1:_)
-  = throwDyn $ mkPlainErrMsg noSrcSpan $
+  = throwErrMsg $ mkPlainErrMsg noSrcSpan $
 	text "module" <+> quotes (ppr mod) <+> 
 	text "is defined in multiple files:" <+>
 	sep (map text files)
@@ -2243,11 +2273,11 @@ findModule s mod_name maybe_pkg = withSession s $ \hsc_env ->
 	  res <- findImportedModule hsc_env mod_name maybe_pkg
 	  case res of
 	    Found _ m | modulePackageId m /= this_pkg -> return m
-		      | otherwise -> throwDyn (CmdLineError (showSDoc $
+		      | otherwise -> ghcError (CmdLineError (showSDoc $
 					text "module" <+> quotes (ppr (moduleName m)) <+>
 					text "is not loaded"))
 	    err -> let msg = cannotFindModule dflags mod_name err in
-		   throwDyn (CmdLineError (showSDoc msg))
+		   ghcError (CmdLineError (showSDoc msg))
 
 #ifdef GHCI
 getHistorySpan :: Session -> History -> IO SrcSpan