import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
+import ErrUtils ( putMsg, debugTraceMsg )
import Panic ( GhcException(..) )
import Util ( Suffix, global, notNull, consIORef,
normalisePath, pgmPath, platformPath )
import Monad ( when, unless )
import System ( ExitCode(..), getEnv, system )
import IO ( try, catch,
- openFile, hPutStrLn, hPutStr, hClose, hFlush, IOMode(..),
- stderr )
+ openFile, hPutStr, hClose, hFlush, IOMode(..),
+ stderr, ioError, isDoesNotExistError )
import Directory ( doesFileExist, removeFile )
import List ( partition )
#if __GLASGOW_HASKELL__ < 603
-- rawSystem comes from libghccompat.a in stage1
import Compat.RawSystem ( rawSystem )
+import GHC.IOBase ( IOErrorType(..) )
+import System.IO.Error ( ioeGetErrorType )
#else
import System.Cmd ( rawSystem )
#endif
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
- when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose)
+ debugTraceMsg dflags 2 ("*** " ++ purpose)
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
newTempName :: DynFlags -> Suffix -> IO FilePath
newTempName DynFlags{tmpDir=tmp_dir} extn
= do x <- getProcessID
- findTempName tmp_dir x
+ findTempName (tmp_dir ++ "/ghc" ++ show x ++ "_") 0
where
- findTempName tmp_dir x
- = do let filename = tmp_dir ++ "/ghc" ++ show x ++ '.':extn
+ findTempName prefix x
+ = do let filename = prefix ++ show x ++ '.':extn
b <- doesFileExist filename
- if b then findTempName tmp_dir (x+1)
+ if b then findTempName prefix (x+1)
else do consIORef v_FilesToClean filename -- clean it up later
return filename
("Deleting: " ++ unwords deletees)
(mapM_ rm deletees)
where
- verb = verbosity dflags
-
-- Flat out refuse to delete files that are likely to be source input
-- files (is there a worse bug than having a compiler delete your source
-- files?)
warnNon act
| null non_deletees = act
| otherwise = do
- hPutStrLn stderr ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+ putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch`
(\_ignored ->
- when (verb >= 2) $
- hPutStrLn stderr ("Warning: deleting non-existent " ++ f)
+ debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
)
runSomething dflags phase_name pgm args = do
let real_args = filter notNull (map showOpt args)
traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
- exit_code <- rawSystem pgm real_args
- case exit_code of
- ExitSuccess ->
- return ()
- -- rawSystem returns (ExitFailure 127) if the exec failed for any
- -- reason (eg. the program doesn't exist). This is the only clue
- -- we have, but we need to report something to the user because in
- -- the case of a missing program there will otherwise be no output
- -- at all.
- ExitFailure 127 ->
- throwDyn (InstallationError ("could not execute: " ++ pgm))
- ExitFailure _other ->
- throwDyn (PhaseFailed phase_name exit_code)
+ (exit_code, doesn'tExist) <-
+ IO.catch (do
+ rc <- rawSystem pgm real_args
+ case rc of
+ ExitSuccess{} -> return (rc, False)
+ ExitFailure n
+ -- rawSystem returns (ExitFailure 127) if the exec failed for any
+ -- reason (eg. the program doesn't exist). This is the only clue
+ -- we have, but we need to report something to the user because in
+ -- the case of a missing program there will otherwise be no output
+ -- at all.
+ | n == 127 -> return (rc, True)
+ | otherwise -> return (rc, False))
+ -- Should 'rawSystem' generate an IO exception indicating that
+ -- 'pgm' couldn't be run rather than a funky return code, catch
+ -- this here (the win32 version does this, but it doesn't hurt
+ -- to test for this in general.)
+ (\ err ->
+ if IO.isDoesNotExistError err
+#if defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ < 604
+ -- the 'compat' version of rawSystem under mingw32 always
+ -- maps 'errno' to EINVAL to failure.
+ || case (ioeGetErrorType err ) of { InvalidArgument{} -> True ; _ -> False}
+#endif
+ then return (ExitFailure 1, True)
+ else IO.ioError err)
+ case (doesn'tExist, exit_code) of
+ (True, _) -> throwDyn (InstallationError ("could not execute: " ++ pgm))
+ (_, ExitSuccess) -> return ()
+ _ -> throwDyn (PhaseFailed phase_name exit_code)
showOpt (FileOption pre f) = pre ++ platformPath f
showOpt (Option "") = ""
-- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
- ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name)
- ; when (verb >= 3) $ hPutStrLn stderr cmd_line
+ ; debugTraceMsg dflags 2 ("*** " ++ phase_name)
+ ; debugTraceMsg dflags 3 cmd_line
; hFlush stderr
-- Test for -n flag
; action `IO.catch` handle_exn verb
}}
where
- handle_exn verb exn = do { when (verb >= 2) (hPutStr stderr "\n")
- ; when (verb >= 3) (hPutStrLn stderr ("Failed: " ++ cmd_line ++ (show exn)))
+ handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
+ ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
-----------------------------------------------------------------------------
-- Define getBaseDir :: IO (Maybe String)
-#if defined(mingw32_HOST_OS)
getBaseDir :: IO (Maybe String)
+#if defined(mingw32_HOST_OS)
-- Assuming we are running ghc, accessed by path $()/bin/ghc.exe,
-- return the path $(stuff). Note that we drop the "bin/" directory too.
getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32.
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
-getBaseDir :: IO (Maybe String) = do return Nothing
+getBaseDir = return Nothing
#endif
#ifdef mingw32_HOST_OS
projects / ghc-hetmet.git / blobdiff